From e0f9a9d921e6e505c86ef3e798690784f7abd511 Mon Sep 17 00:00:00 2001 From: adamc Date: Thu, 23 Oct 2008 11:38:31 -0400 Subject: Add newline at end of file --- src/compiler.sml | 1 + 1 file changed, 1 insertion(+) diff --git a/src/compiler.sml b/src/compiler.sml index 2ddcfb4d..df4ee48d 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -555,6 +555,7 @@ fun compile job = val s = TextIOPP.openOut {dst = outf, wid = 80} in Print.fprint s (CjrPrint.p_file CjrEnv.empty file); + TextIO.output1 (outf, #"\n"); TextIO.closeOut outf; case #sql job of -- cgit v1.2.3 From 833f4d2e0474ec3ff772107b52711289c4b648cf Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 23 Oct 2008 11:59:48 -0400 Subject: Counter demo --- demo/counter.ur | 7 +++++++ demo/counter.urp | 2 ++ demo/counter.urs | 1 + demo/prose | 8 ++++++-- 4 files changed, 16 insertions(+), 2 deletions(-) create mode 100644 demo/counter.ur create mode 100644 demo/counter.urp create mode 100644 demo/counter.urs diff --git a/demo/counter.ur b/demo/counter.ur new file mode 100644 index 00000000..b11fc936 --- /dev/null +++ b/demo/counter.ur @@ -0,0 +1,7 @@ +fun counter n = return + Current counter: {[n]}
+ Increment
+ Decrement + + +fun main () = counter 0 diff --git a/demo/counter.urp b/demo/counter.urp new file mode 100644 index 00000000..d22312c9 --- /dev/null +++ b/demo/counter.urp @@ -0,0 +1,2 @@ + +counter diff --git a/demo/counter.urs b/demo/counter.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/demo/counter.urs @@ -0,0 +1 @@ +val main : unit -> transaction page diff --git a/demo/prose b/demo/prose index 7f9f6bb0..8fedc557 100644 --- a/demo/prose +++ b/demo/prose @@ -44,12 +44,16 @@ rec.urp

Crafting webs of interlinked pages is easy, using recursion.

+counter.urp + +

It is also easy to pass state around via functions, in the style commonly associated with "continuation-based" web servers. As is usual for such systems, all state is stored on the client side. In this case, it is encoded in URLs.

+ +

In the implementation of Counter.counter, we see the notation {[...]}, which uses type classes to inject values of different types (int in this case) into XML. It's probably worth stating explicitly that XML fragments are not strings, so that the type-checker will enforce that our final piece of XML is valid.

+ form.urp

Here we see a basic form. The type system tracks which form inputs we include, and it enforces that the form handler function expects a record containing exactly those fields, with exactly the proper types.

-

In the implementation of handler, we see the notation {[...]}, which uses type classes to inject values of different types (string and bool in this case) into XML. It's probably worth stating explicitly that XML fragments are not strings, so that the type-checker will enforce that our final piece of XML is valid.

- listShop.urp

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

-- cgit v1.2.3 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 --- demo/prose | 4 ++ demo/tcSum.ur | 9 +++++ demo/tcSum.urp | 2 + demo/tcSum.urs | 1 + lib/basis.urs | 1 + src/core_env.sml | 14 +++---- src/monoize.sml | 20 ++++++++-- src/reduce.sml | 115 ++++++++++++++++++++++++++++++------------------------- 8 files changed, 103 insertions(+), 63 deletions(-) create mode 100644 demo/tcSum.ur create mode 100644 demo/tcSum.urp create mode 100644 demo/tcSum.urs diff --git a/demo/prose b/demo/prose index 8fedc557..19e9df0f 100644 --- a/demo/prose +++ b/demo/prose @@ -100,3 +100,7 @@ An unusual part of the third argument is the syntax [t1 ~ t2] within a

The general syntax for constant row types is [Name1 = t1, ..., NameN = tN], and there is a shorthand version [Name1, ..., NameN] for records of Units.

With sum defined, it is easy to make some sample calls. The form of the code for main does not make it apparent, but the compiler must "reverse engineer" the appropriate {Unit} from the {Type} available from the context at each call to sum.

+ +tcSum.urp + +

It's easy to adapt the last example to use type classes, such that we can sum the fields of records based on any numeric type.

diff --git a/demo/tcSum.ur b/demo/tcSum.ur new file mode 100644 index 00000000..53679116 --- /dev/null +++ b/demo/tcSum.ur @@ -0,0 +1,9 @@ +fun sum (t ::: Type) (_ : num t) (fs ::: {Unit}) (x : $(mapUT t fs)) = + foldUR [t] [fn _ => t] + (fn (nm :: Name) (rest :: {Unit}) [[nm] ~ rest] n acc => n + acc) + zero [fs] x + +fun main () = return + {[sum {A = 0, B = 1}]}
+ {[sum {C = 2.1, D = 3.2, E = 4.3}]} + diff --git a/demo/tcSum.urp b/demo/tcSum.urp new file mode 100644 index 00000000..8b36efc0 --- /dev/null +++ b/demo/tcSum.urp @@ -0,0 +1,2 @@ + +tcSum diff --git a/demo/tcSum.urs b/demo/tcSum.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/demo/tcSum.urs @@ -0,0 +1 @@ +val main : unit -> transaction page diff --git a/lib/basis.urs b/lib/basis.urs index a539f05e..a8c81353 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -20,6 +20,7 @@ val eq_string : eq string val eq_bool : eq bool class num +val zero : t ::: Type -> num t -> t val neg : t ::: Type -> num t -> t -> t val plus : t ::: Type -> num t -> t -> t -> t val minus : t ::: Type -> num t -> t -> t -> t diff --git a/src/core_env.sml b/src/core_env.sml index a4b48b8d..b399f62f 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -82,13 +82,13 @@ val liftConInExp = val subConInExp = U.Exp.mapB {kind = fn k => k, con = fn (xn, rep) => fn c => - case c of - CRel xn' => - (case Int.compare (xn', xn) of - EQUAL => #1 rep - | GREATER => CRel (xn' - 1) - | LESS => c) - | _ => c, + case c of + CRel xn' => + (case Int.compare (xn', xn) of + EQUAL => #1 rep + | GREATER => CRel (xn' - 1) + | LESS => c) + | _ => c, exp = fn _ => fn e => e, bind = fn ((xn, rep), U.Exp.RelC _) => (xn+1, liftConInCon 0 rep) | (ctx, _) => ctx} 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), diff --git a/src/reduce.sml b/src/reduce.sml index 0250175f..927c8ff1 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -36,6 +36,7 @@ structure U = CoreUtil val liftConInCon = E.liftConInCon val subConInCon = E.subConInCon +val liftConInExp = E.liftConInExp val liftExpInExp = U.Exp.mapB {kind = fn k => k, @@ -63,6 +64,7 @@ val subExpInExp = | LESS => e) | _ => e, bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep) + | ((xn, rep), U.Exp.RelC _) => (xn, liftConInExp 0 rep) | (ctx, _) => ctx} val liftConInExp = E.liftConInExp @@ -106,58 +108,67 @@ fun con env c = and reduceCon env = U.Con.mapB {kind = kind, con = con, bind = bindC} env fun exp env e = - case e of - ENamed n => - (case E.lookupENamed env n of - (_, _, SOME e', _) => #1 e' - | _ => e) - - | ECApp ((EApp ((EApp ((ECApp ((EFold ks, _), ran), _), f), _), i), _), (CRecord (k, xcs), loc)) => - (case xcs of - [] => #1 i - | (n, v) :: rest => - #1 (reduceExp env (EApp ((ECApp ((ECApp ((ECApp (f, n), loc), v), loc), (CRecord (k, rest), loc)), loc), - (ECApp ((EApp ((EApp ((ECApp ((EFold ks, loc), ran), loc), f), loc), i), loc), - (CRecord (k, rest), loc)), loc)), loc))) - - | EApp ((EAbs (_, _, _, e1), loc), e2) => - #1 (reduceExp env (subExpInExp (0, e2) e1)) - | ECApp ((ECAbs (_, _, e1), loc), c) => - #1 (reduceExp env (subConInExp (0, c) e1)) - - | EField ((ERecord xes, _), (CName x, _), _) => - (case List.find (fn ((CName x', _), _, _) => x' = x - | _ => false) xes of - SOME (_, e, _) => #1 e - | NONE => e) - | EWith (r as (_, loc), x, e, {rest = (CRecord (k, xts), _), field}) => - 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 ((x, e, field) :: fields (xts, [])), loc)) - end - | ECut (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 + let + (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp env (e, ErrorMsg.dummySpan))]*) + + val r = case e of + ENamed n => + (case E.lookupENamed env n of + (_, _, SOME e', _) => #1 e' + | _ => e) + + | ECApp ((EApp ((EApp ((ECApp ((EFold ks, _), ran), _), f), _), i), _), (CRecord (k, xcs), loc)) => + (case xcs of + [] => #1 i + | (n, v) :: rest => + #1 (reduceExp env (EApp ((ECApp ((ECApp ((ECApp (f, n), loc), v), loc), (CRecord (k, rest), loc)), loc), + (ECApp ((EApp ((EApp ((ECApp ((EFold ks, loc), ran), loc), f), loc), i), loc), + (CRecord (k, rest), loc)), loc)), loc))) + + | EApp ((EAbs (_, _, _, e1), loc), e2) => + #1 (reduceExp env (subExpInExp (0, e2) e1)) + | ECApp ((ECAbs (_, _, e1), loc), c) => + #1 (reduceExp env (subConInExp (0, c) e1)) + + | EField ((ERecord xes, _), (CName x, _), _) => + (case List.find (fn ((CName x', _), _, _) => x' = x + | _ => false) xes of + SOME (_, e, _) => #1 e + | NONE => e) + | EWith (r as (_, loc), x, e, {rest = (CRecord (k, xts), _), field}) => + 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 ((x, e, field) :: fields (xts, [])), loc)) + end + | ECut (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 + (*Print.prefaces "exp'" [("e", CorePrint.p_exp env (e, ErrorMsg.dummySpan)), + ("r", CorePrint.p_exp env (r, ErrorMsg.dummySpan))];*) + + r + end and reduceExp env = U.Exp.mapB {kind = kind, con = con, exp = exp, bind = bind} env -- cgit v1.2.3 From a2495d384c7747a079cb0f4bc31f44d626391068 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 23 Oct 2008 14:03:12 -0400 Subject: Metaform demos, minus prose --- demo/metaform.ur | 28 ++++++++++++++++++++++++++++ demo/metaform.urs | 6 ++++++ demo/metaform1.ur | 3 +++ demo/metaform1.urp | 3 +++ demo/metaform1.urs | 1 + demo/metaform2.ur | 12 ++++++++++++ demo/metaform2.urp | 3 +++ demo/metaform2.urs | 1 + demo/prose | 4 ++++ lib/top.ur | 20 ++++++++++++++++++++ lib/top.urs | 12 ++++++++++++ src/cjr_print.sml | 3 ++- 12 files changed, 95 insertions(+), 1 deletion(-) create mode 100644 demo/metaform.ur create mode 100644 demo/metaform.urs create mode 100644 demo/metaform1.ur create mode 100644 demo/metaform1.urp create mode 100644 demo/metaform1.urs create mode 100644 demo/metaform2.ur create mode 100644 demo/metaform2.urp create mode 100644 demo/metaform2.urs diff --git a/demo/metaform.ur b/demo/metaform.ur new file mode 100644 index 00000000..ae1197f4 --- /dev/null +++ b/demo/metaform.ur @@ -0,0 +1,28 @@ +functor Make (M : sig + con fs :: {Unit} + val names : $(mapUT string fs) + end) = struct + + fun handler values = return + {foldURX2 [string] [string] [body] + (fn (nm :: Name) (rest :: {Unit}) [[nm] ~ rest] name value => +
  • {[name]} = {[value]}
    • +     ) + [M.fs] M.names values} +     + + fun main () = return +
    + {foldUR [string] [fn cols :: {Unit} => xml form [] (mapUT string cols)] + (fn (nm :: Name) (rest :: {Unit}) [[nm] ~ rest] name + (acc : xml form [] (mapUT string rest)) => +
  • {[name]}:
    • + {useMore acc} +     ) + + [M.fs] M.names} + + +
    + +end diff --git a/demo/metaform.urs b/demo/metaform.urs new file mode 100644 index 00000000..7a3fa62e --- /dev/null +++ b/demo/metaform.urs @@ -0,0 +1,6 @@ +functor Make (M : sig + con fs :: {Unit} + val names : $(mapUT string fs) + end) : sig + val main : unit -> transaction page +end diff --git a/demo/metaform1.ur b/demo/metaform1.ur new file mode 100644 index 00000000..c6a4664d --- /dev/null +++ b/demo/metaform1.ur @@ -0,0 +1,3 @@ +open Metaform.Make(struct + val names = {A = "Tic", B = "Tac", C = "Toe"} + end) diff --git a/demo/metaform1.urp b/demo/metaform1.urp new file mode 100644 index 00000000..7f04b9b7 --- /dev/null +++ b/demo/metaform1.urp @@ -0,0 +1,3 @@ + +metaform +metaform1 diff --git a/demo/metaform1.urs b/demo/metaform1.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/demo/metaform1.urs @@ -0,0 +1 @@ +val main : unit -> transaction page diff --git a/demo/metaform2.ur b/demo/metaform2.ur new file mode 100644 index 00000000..430a42f0 --- /dev/null +++ b/demo/metaform2.ur @@ -0,0 +1,12 @@ +structure MM = Metaform.Make(struct + val names = {X = "x", Y = "y"} + end) + +fun diversion () = return + Welcome to the diversion. + + +fun main () = return +
  • See something shiny!
    • +
  • Fill out a form!
    • +     diff --git a/demo/metaform2.urp b/demo/metaform2.urp new file mode 100644 index 00000000..debc0448 --- /dev/null +++ b/demo/metaform2.urp @@ -0,0 +1,3 @@ + +metaform +metaform2 diff --git a/demo/metaform2.urs b/demo/metaform2.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/demo/metaform2.urs @@ -0,0 +1 @@ +val main : unit -> transaction page diff --git a/demo/prose b/demo/prose index 19e9df0f..4fb07673 100644 --- a/demo/prose +++ b/demo/prose @@ -104,3 +104,7 @@ An unusual part of the third argument is the syntax [t1 ~ t2] within a tcSum.urp

    It's easy to adapt the last example to use type classes, such that we can sum the fields of records based on any numeric type.

    + +metaform1.urp + +metaform2.urp diff --git a/lib/top.ur b/lib/top.ur index ab506c80..91cab991 100644 --- a/lib/top.ur +++ b/lib/top.ur @@ -36,6 +36,26 @@ fun foldUR (tf :: Type) (tr :: {Unit} -> Type) f [nm] [rest] r.nm (acc (r -- nm))) (fn _ => i) +fun foldUR2 (tf1 :: Type) (tf2 :: Type) (tr :: {Unit} -> Type) + (f : nm :: Name -> rest :: {Unit} + -> fn [[nm] ~ rest] => + tf1 -> tf2 -> tr rest -> tr ([nm] ++ rest)) + (i : tr []) = + fold [fn r :: {Unit} => $(mapUT tf1 r) -> $(mapUT tf2 r) -> tr r] + (fn (nm :: Name) (t :: Unit) (rest :: {Unit}) acc + [[nm] ~ rest] r1 r2 => + f [nm] [rest] r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm))) + (fn _ _ => i) + +fun foldURX2 (tf1 :: Type) (tf2 :: Type) (ctx :: {Unit}) + (f : nm :: Name -> rest :: {Unit} + -> fn [[nm] ~ rest] => + tf1 -> tf2 -> xml ctx [] []) = + foldUR2 [tf1] [tf2] [fn _ => xml ctx [] []] + (fn (nm :: Name) (rest :: {Unit}) [[nm] ~ rest] v1 v2 acc => + {f [nm] [rest] v1 v2}{acc}) + + fun foldTR (tf :: Type -> Type) (tr :: {Type} -> Type) (f : nm :: Name -> t :: Type -> rest :: {Type} -> fn [[nm] ~ rest] => diff --git a/lib/top.urs b/lib/top.urs index abdb7477..29a1acf1 100644 --- a/lib/top.urs +++ b/lib/top.urs @@ -29,6 +29,18 @@ val foldUR : tf :: Type -> tr :: ({Unit} -> Type) tf -> tr rest -> tr ([nm] ++ rest)) -> tr [] -> r :: {Unit} -> $(mapUT tf r) -> tr r +val foldUR2 : tf1 :: Type -> tf2 :: Type -> tr :: ({Unit} -> Type) + -> (nm :: Name -> rest :: {Unit} + -> fn [[nm] ~ rest] => + tf1 -> tf2 -> tr rest -> tr ([nm] ++ rest)) + -> tr [] -> r :: {Unit} -> $(mapUT tf1 r) -> $(mapUT tf2 r) -> tr r + +val foldURX2: tf1 :: Type -> tf2 :: Type -> ctx :: {Unit} + -> (nm :: Name -> rest :: {Unit} + -> fn [[nm] ~ rest] => + tf1 -> tf2 -> xml ctx [] []) + -> r :: {Unit} -> $(mapUT tf1 r) -> $(mapUT tf2 r) -> xml ctx [] [] + val foldTR : tf :: (Type -> Type) -> tr :: ({Type} -> Type) -> (nm :: Name -> t :: Type -> rest :: {Type} -> fn [[nm] ~ rest] => diff --git a/src/cjr_print.sml b/src/cjr_print.sml index f2af999b..089f98a1 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1466,7 +1466,8 @@ fun p_file env (ds, ps) = let fun unurlify' rf t = case t of - TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)") + 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 => -- cgit v1.2.3 From da7b52ba28367cf2b31476e77e1a26e53e4765e4 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 23 Oct 2008 17:35:10 -0400 Subject: Fix bug with bringing functor argument instances into scope; Ref demo, minus prose --- demo/prose | 2 ++ demo/ref.ur | 28 +++++++++++++++ demo/ref.urp | 4 +++ demo/ref.urs | 1 + demo/refFun.ur | 27 ++++++++++++++ demo/refFun.urs | 10 ++++++ src/elab_env.sml | 105 ++++++++++++++++++++++++++++++++++++++----------------- 7 files changed, 145 insertions(+), 32 deletions(-) create mode 100644 demo/ref.ur create mode 100644 demo/ref.urp create mode 100644 demo/ref.urs create mode 100644 demo/refFun.ur create mode 100644 demo/refFun.urs diff --git a/demo/prose b/demo/prose index 4fb07673..05bafd11 100644 --- a/demo/prose +++ b/demo/prose @@ -108,3 +108,5 @@ tcSum.urp metaform1.urp metaform2.urp + +ref.urp diff --git a/demo/ref.ur b/demo/ref.ur new file mode 100644 index 00000000..089529e3 --- /dev/null +++ b/demo/ref.ur @@ -0,0 +1,28 @@ +structure IR = RefFun.Make(struct + type t = int + val inj = _ + end) + +structure SR = RefFun.Make(struct + type t = string + val inj = _ + end) + +fun main () = + ir <- IR.new 3; + ir' <- IR.new 7; + sr <- SR.new "hi"; + + () <- IR.write ir' 10; + + iv <- IR.read ir; + iv' <- IR.read ir'; + sv <- SR.read sr; + + () <- IR.delete ir; + () <- IR.delete ir'; + () <- SR.delete sr; + + return + {[iv]}, {[iv']}, {[sv]} + diff --git a/demo/ref.urp b/demo/ref.urp new file mode 100644 index 00000000..c00e5406 --- /dev/null +++ b/demo/ref.urp @@ -0,0 +1,4 @@ +database dbname=test + +refFun +ref diff --git a/demo/ref.urs b/demo/ref.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/demo/ref.urs @@ -0,0 +1 @@ +val main : unit -> transaction page diff --git a/demo/refFun.ur b/demo/refFun.ur new file mode 100644 index 00000000..d58acee5 --- /dev/null +++ b/demo/refFun.ur @@ -0,0 +1,27 @@ +functor Make(M : sig + type data + val inj : sql_injectable data + end) = struct + + type ref = int + + sequence s + table t : { Id : int, Data : M.data } + + fun new d = + id <- nextval s; + () <- 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}); + 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}) + + fun delete r = + dml (DELETE FROM t WHERE Id = {r}) +end diff --git a/demo/refFun.urs b/demo/refFun.urs new file mode 100644 index 00000000..bcecc8d3 --- /dev/null +++ b/demo/refFun.urs @@ -0,0 +1,10 @@ +functor Make(M : sig + type data + val inj : sql_injectable data + end) : sig + type ref + val new : M.data -> transaction ref + val read : ref -> transaction M.data + val write : ref -> M.data -> transaction unit + val delete : ref -> transaction unit +end diff --git a/src/elab_env.sml b/src/elab_env.sml index 958d369c..edda9f38 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -159,10 +159,11 @@ val empty_class = { ground = KM.empty } -fun printClasses cs = CM.appi (fn (cn, {ground = km}) => - (print (cn2s cn ^ ":"); - KM.appi (fn (ck, _) => print (" " ^ ck2s ck)) km; - print "\n")) cs +fun printClasses cs = (print "Classes:\n"; + CM.appi (fn (cn, {ground = km}) => + (print (cn2s cn ^ ":"); + KM.appi (fn (ck, _) => print (" " ^ ck2s ck)) km; + print "\n")) cs) type env = { renameC : kind var' SM.map, @@ -743,34 +744,74 @@ fun enrichClasses env classes (m1, ms) sgn = | SgiClassAbs xn => found xn | SgiClass (x, n, _) => found (x, n) - | SgiVal (x, n, (CApp ((CNamed f, _), a), _)) => - (case IM.find (newClasses, f) of - NONE => default () - | SOME fx => - case class_key_in (sgnS_con' (m1, ms, fmap) (#1 a), #2 a) of - NONE => default () - | SOME ck => - let - val cn = ClProj (m1, ms, fx) - - val classes = - case CM.find (classes, cn) of - NONE => classes - | SOME class => - let - val class = { - ground = KM.insert (#ground class, ck, - (EModProj (m1, ms, x), #2 sgn)) - } - in - CM.insert (classes, cn, class) - end - in - (classes, - newClasses, - fmap, - env) - end) + | SgiVal (x, n, (CApp (f, a), _)) => + let + fun unravel c = + case #1 c of + CUnif (_, _, _, ref (SOME c)) => unravel c + | CNamed n => + ((case lookupCNamed env n of + (_, _, SOME c) => unravel c + | _ => c) + handle UnboundNamed _ => c) + | _ => c + + val nc = + case f of + (CNamed f, _) => IM.find (newClasses, f) + | _ => NONE + in + case nc of + NONE => + (case (class_name_in (unravel f), + class_key_in (sgnS_con' (m1, ms, fmap) (#1 a), #2 a)) of + (SOME cn, SOME ck) => + let + val classes = + case CM.find (classes, cn) of + NONE => classes + | SOME class => + let + val class = { + ground = KM.insert (#ground class, ck, + (EModProj (m1, ms, x), #2 sgn)) + } + in + CM.insert (classes, cn, class) + end + in + (classes, + newClasses, + fmap, + env) + end + | _ => default ()) + | SOME fx => + case class_key_in (sgnS_con' (m1, ms, fmap) (#1 a), #2 a) of + NONE => default () + | SOME ck => + let + val cn = ClProj (m1, ms, fx) + + val classes = + case CM.find (classes, cn) of + NONE => classes + | SOME class => + let + val class = { + ground = KM.insert (#ground class, ck, + (EModProj (m1, ms, x), #2 sgn)) + } + in + CM.insert (classes, cn, class) + end + in + (classes, + newClasses, + fmap, + env) + end + end | SgiVal _ => default () | _ => default () end) -- cgit v1.2.3 From c083f2b0659545c9a0f36faf1a56239f4efc8df2 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 23 Oct 2008 17:52:04 -0400 Subject: Prose for Ref and Metaform --- demo/prose | 13 ++++++++++++- demo/refFun.ur | 1 + 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/demo/prose b/demo/prose index 05bafd11..e447aee3 100644 --- a/demo/prose +++ b/demo/prose @@ -76,6 +76,12 @@ sql.urp

    +ref.urp + +

    This example shows how to mix the module system with SQL to implement a kind of "abstract data type." The functor RefFun.Make takes in a type belonging to the type class of those types that may be included in SQL. The functor output includes an abstract type ref, along with operations for working with refs via transactions. In the functor implementation, we see that ref is implemented as int, treated as primary keys of a SQL table.

    + +

    The functor creates a new encapsulated SQL sequence and table on each call. These local relations show up in the automatically-generated SQL file that should be run to prepare the database for use, but they are invisible from client code. We could change the functor to create different SQL relations, without needing to change client code.

    + sum.urp

    Metaprogramming is one of the most important facilities of Ur. This example shows how to write a function that is able to sum up the fields of records of integers, no matter which set of fields the particular record has.

    @@ -107,6 +113,11 @@ tcSum.urp metaform1.urp +

    We can use metaprogramming with row types to build HTML forms (and their handlers) generically. The functor Metaform.Make takes in a unit row fs and a value-level record names assigning string names to the fields of fs. The functor implementation builds a form handler with a library function foldURX2, which runs over two value-level records in parallel, building an XML fragment.

    + +

    The form itself is generated using the more primitive foldUR. We see the type xml form [] (mapUT string cols) as the result of the fold. This is the type of XML fragments that are suitable for inclusion in forms, require no form fields to be defined on entry, and themselves define form fields whose names and types are given by mapUT string cols. The useMore function "weakens" the type of an XML fragment, so that it "pretends" to require additional fields as input. This weakening is necessary to accommodate the general typing rule for concatenating bits of XML. +

    The functor use in Metaform1 is trivial. The compiler infers the value of the structure member fs from the type of the value provided for names.

    + metaform2.urp -ref.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.

    diff --git a/demo/refFun.ur b/demo/refFun.ur index d58acee5..a090b297 100644 --- a/demo/refFun.ur +++ b/demo/refFun.ur @@ -24,4 +24,5 @@ functor Make(M : sig fun delete r = dml (DELETE FROM t WHERE Id = {r}) + end -- cgit v1.2.3 From fbde7928c43149e02806949343783dc6e885ab0f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 23 Oct 2008 18:18:51 -0400 Subject: Crud demo --- demo/crud.ur | 178 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ demo/crud.urs | 26 +++++++++ demo/crud1.ur | 12 ++++ demo/crud1.urp | 5 ++ demo/prose | 31 ++++++++++ demo/ref.urp | 1 + demo/sql.urp | 1 + 7 files changed, 254 insertions(+) create mode 100644 demo/crud.ur create mode 100644 demo/crud.urs create mode 100644 demo/crud1.ur create mode 100644 demo/crud1.urp diff --git a/demo/crud.ur b/demo/crud.ur new file mode 100644 index 00000000..472de6d4 --- /dev/null +++ b/demo/crud.ur @@ -0,0 +1,178 @@ +con colMeta = fn t_formT :: (Type * Type) => { + Nam : string, + Show : t_formT.1 -> xbody, + Widget : nm :: Name -> xml form [] [nm = t_formT.2], + WidgetPopulated : nm :: Name -> t_formT.1 -> xml form [] [nm = t_formT.2], + Parse : t_formT.2 -> t_formT.1, + Inject : sql_injectable t_formT.1 + } +con colsMeta = fn cols :: {(Type * Type)} => $(Top.mapT2T colMeta cols) + +fun default (t ::: Type) (sh : show t) (rd : read t) (inj : sql_injectable t) + name : colMeta (t, string) = + {Nam = name, + Show = txt, + Widget = fn nm :: Name => , + WidgetPopulated = fn (nm :: Name) n => + , + Parse = readError, + Inject = _} + +val int = default +val float = default +val string = default + +fun bool name = {Nam = name, + Show = txt, + Widget = fn nm :: Name => , + WidgetPopulated = fn (nm :: Name) b => + , + Parse = fn x => x, + Inject = _} + +functor Make(M : sig + con cols :: {(Type * Type)} + constraint [Id] ~ cols + val tab : sql_table ([Id = int] ++ mapT2T fstTT cols) + + val title : string + + val cols : colsMeta cols + end) = struct + + open constraints M + val tab = M.tab + + sequence seq + + fun list () = + rows <- queryX (SELECT * FROM tab AS T) + (fn (fs : {T : $([Id = int] ++ mapT2T fstTT M.cols)}) => + + {[fs.T.Id]} + {foldT2RX2 [fstTT] [colMeta] [tr] + (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) + [[nm] ~ rest] v col => + {col.Show v} + ) + [M.cols] (fs.T -- #Id) M.cols} + + [Update] + [Delete] + + + ); + return + + + + {foldT2RX [colMeta] [tr] + (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) + [[nm] ~ rest] col => + + ) + [M.cols] M.cols} + + {rows} +
    ID{cdata col.Nam}
    + +

    + +
    + {foldT2R [colMeta] [fn cols :: {(Type * Type)} => xml form [] (mapT2T sndTT cols)] + (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) + [[nm] ~ rest] (col : colMeta t) (acc : xml form [] (mapT2T sndTT rest)) => +
  • {cdata col.Nam}: {col.Widget [nm]}
    • + {useMore acc} +     ) + + [M.cols] M.cols} + + + +
    + + and create (inputs : $(mapT2T sndTT M.cols)) = + id <- nextval seq; + () <- dml (insert tab + (foldT2R2 [sndTT] [colMeta] + [fn cols => $(mapT2T (fn t :: (Type * Type) => + sql_exp [] [] [] t.1) cols)] + (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) + [[nm] ~ rest] => + fn input col acc => acc with nm = @sql_inject col.Inject (col.Parse input)) + {} [M.cols] inputs M.cols + with #Id = (SQL {id}))); + ls <- list (); + return +

    Inserted with ID {[id]}.

    + + {ls} +     + + and save (id : int) (inputs : $(mapT2T sndTT M.cols)) = + () <- dml (update [mapT2T fstTT M.cols] + (foldT2R2 [sndTT] [colMeta] + [fn cols => $(mapT2T (fn t :: (Type * Type) => + sql_exp [T = [Id = int] + ++ mapT2T fstTT M.cols] + [] [] t.1) cols)] + (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) + [[nm] ~ rest] => + fn input col acc => acc with nm = + @sql_inject col.Inject (col.Parse input)) + {} [M.cols] inputs M.cols) + tab (WHERE T.Id = {id})); + ls <- list (); + return +

    Saved!

    + + {ls} +     + + and upd (id : int) = + 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
    + {foldT2R2 [fstTT] [colMeta] [fn cols :: {(Type * Type)} => xml form [] (mapT2T sndTT cols)] + (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) + [[nm] ~ rest] (v : t.1) (col : colMeta t) + (acc : xml form [] (mapT2T sndTT rest)) => + +
  • {cdata col.Nam}: {col.WidgetPopulated [nm] v}
    • + {useMore acc} +     ) + + [M.cols] fs.Tab M.cols} + + +
    + + and delete (id : int) = + () <- dml (DELETE FROM tab WHERE Id = {id}); + ls <- list (); + return +

    The deed is done.

    + + {ls} +     + + and confirm (id : int) = return +

    Are you sure you want to delete ID #{[id]}?

    + +

    I was born sure!

    +     + + and main () = + ls <- list (); + return + {cdata M.title} + + +

    {cdata M.title}

    + + {ls} +     + +end diff --git a/demo/crud.urs b/demo/crud.urs new file mode 100644 index 00000000..33090421 --- /dev/null +++ b/demo/crud.urs @@ -0,0 +1,26 @@ +con colMeta = fn t_formT :: (Type * Type) => + {Nam : string, + Show : t_formT.1 -> xbody, + Widget : nm :: Name -> xml form [] [nm = t_formT.2], + WidgetPopulated : nm :: Name -> t_formT.1 + -> xml form [] [nm = t_formT.2], + Parse : t_formT.2 -> t_formT.1, + Inject : sql_injectable t_formT.1} +con colsMeta = fn cols :: {(Type * Type)} => $(mapT2T colMeta cols) + +val int : string -> colMeta (int, string) +val float : string -> colMeta (float, string) +val string : string -> colMeta (string, string) +val bool : string -> colMeta (bool, bool) + +functor Make(M : sig + con cols :: {(Type * Type)} + constraint [Id] ~ cols + val tab : sql_table ([Id = int] ++ mapT2T fstTT cols) + + val title : string + + val cols : colsMeta cols + end) : sig + val main : unit -> transaction page +end diff --git a/demo/crud1.ur b/demo/crud1.ur new file mode 100644 index 00000000..3849e822 --- /dev/null +++ b/demo/crud1.ur @@ -0,0 +1,12 @@ +table t1 : {Id : int, A : int, B : string, C : float, D : bool} + +open Crud.Make(struct + val tab = t1 + + val title = "Crud1" + + val cols = {A = Crud.int "A", + B = Crud.string "B", + C = Crud.float "C", + D = Crud.bool "D"} + end) diff --git a/demo/crud1.urp b/demo/crud1.urp new file mode 100644 index 00000000..bfc2d14e --- /dev/null +++ b/demo/crud1.urp @@ -0,0 +1,5 @@ +database dbname=test +sql crud1.sql + +crud +crud1 diff --git a/demo/prose b/demo/prose index e447aee3..6b7ddf29 100644 --- a/demo/prose +++ b/demo/prose @@ -121,3 +121,34 @@ metaform1.urp 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.

    + +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.

    + +

    The signature of Crud.Make is based around a type function colMeta, which describes which supporting values we need for each column. This function is declared with the keyword con, which stands for "constructor," the general class of "compile-time things" that includes types. An argument to colMeta has kind (Type * Type), which means that it must be a type-level tuple. The first type is how the column is represented in SQL, and the second is how we represent it in HTML forms. In order, the components of the resulting record give: + +

      +
    1. A display name
      2. +
    2. A way of pretty-printing values of the column
      3. +
    3. A way of generating an HTML form widget to input this column
      4. +
    4. A way of generating an HTML form widget with an initial value specified
      5. +
    5. A way of parsing values of the column from strings
      6. +
    6. A type class witness, showing that the SQL representation can really be included in SQL
      7. +

    + +

    The function colsMeta lifts colMeta over type-level records of type pairs. The Crud module also defines reasonable default colMeta values for some primitive types.

    + +

    The functor signature tells us (in order) that an input must contain: + +

      +
    1. A type pair record cols
      2. +
    2. A proof that cols does not contain a field named Id
      3. +
    3. A SQL table tab with an Id field of type int and other fields whose names and types are read off of cols
      4. +
    4. A display title for the admin interface
      5. +
    5. A record of meta-data for the columns
      6. +

    + +

    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.

    diff --git a/demo/ref.urp b/demo/ref.urp index c00e5406..a6bb1de3 100644 --- a/demo/ref.urp +++ b/demo/ref.urp @@ -1,4 +1,5 @@ database dbname=test +sql ref.sql refFun ref diff --git a/demo/sql.urp b/demo/sql.urp index 1b8bb5a4..7894da95 100644 --- a/demo/sql.urp +++ b/demo/sql.urp @@ -1,3 +1,4 @@ database dbname=test +sql sql.sql sql -- 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 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 d27809108ef5ce4ed389cd39562e0dabb4a38c75 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 24 Oct 2008 16:13:53 -0400 Subject: Stop including functors in paths --- src/corify.sml | 37 ++++++++++++++----------------------- 1 file changed, 14 insertions(+), 23 deletions(-) diff --git a/src/corify.sml b/src/corify.sml index 09af27d0..89d1e63f 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -109,9 +109,9 @@ structure St : sig val lookupStrByName : string * t -> t val lookupStrByNameOpt : string * t -> t option - val bindFunctor : t -> string list -> string -> int -> string -> int -> L.str -> t - val lookupFunctorById : t -> int -> string list * string * int * L.str - val lookupFunctorByName : string * t -> string list * string * int * L.str + val bindFunctor : t -> string -> int -> string -> int -> L.str -> t + val lookupFunctorById : t -> int -> string * int * L.str + val lookupFunctorByName : string * t -> string * int * L.str end = struct datatype flattening = @@ -120,7 +120,7 @@ datatype flattening = constructors : L'.patCon SM.map, vals : int SM.map, strs : flattening SM.map, - funs : (string list * string * int * L.str) SM.map} + funs : (string * int * L.str) SM.map} | FFfi of {mod : string, vals : L'.con SM.map, constructors : (string * string list * L'.con option * L'.datatype_kind) SM.map} @@ -131,7 +131,7 @@ type t = { constructors : L'.patCon IM.map, vals : int IM.map, strs : flattening IM.map, - funs : (string list * string * int * L.str) IM.map, + funs : (string * int * L.str) IM.map, current : flattening, nested : flattening list } @@ -405,21 +405,21 @@ fun lookupStrByNameOpt (m, {basis, current = FNormal {strs, ...}, ...} : t) = fun bindFunctor ({basis, cons, constructors, vals, strs, funs, current = FNormal {name, cons = mcons, constructors = mconstructors, vals = mvals, strs = mstrs, funs = mfuns}, nested} : t) - mods x n xa na str = + x n xa na str = {basis = basis, cons = cons, constructors = constructors, vals = vals, strs = strs, - funs = IM.insert (funs, n, (mods, xa, na, str)), + funs = IM.insert (funs, n, (xa, na, str)), current = FNormal {name = name, cons = mcons, constructors = mconstructors, vals = mvals, strs = mstrs, - funs = SM.insert (mfuns, x, (mods, xa, na, str))}, + funs = SM.insert (mfuns, x, (xa, na, str))}, nested = nested} - | bindFunctor _ _ _ _ _ _ _ = raise Fail "Corify.St.bindFunctor" + | bindFunctor _ _ _ _ _ _ = raise Fail "Corify.St.bindFunctor" fun lookupFunctorById ({funs, ...} : t) n = case IM.find (funs, n) of @@ -696,7 +696,7 @@ fun corifyDecl mods ((d, loc : EM.span), st) = | L.DSgn _ => ([], st) | L.DStr (x, n, _, (L.StrFun (xa, na, _, _, str), _)) => - ([], St.bindFunctor st (x :: mods) x n xa na str) + ([], St.bindFunctor st x n xa na str) | L.DStr (x, n, _, (L.StrProj (str, x'), _)) => let @@ -706,9 +706,9 @@ fun corifyDecl mods ((d, loc : EM.span), st) = SOME st' => St.bindStr st x n st' | NONE => let - val (mods', x', n', str') = St.lookupFunctorByName (x', inner) + val (x', n', str') = St.lookupFunctorByName (x', inner) in - St.bindFunctor st mods' x n x' n' str' + St.bindFunctor st x n x' n' str' end in ([], st) @@ -957,20 +957,11 @@ and corifyStr mods ((str, _), st) = | L.StrProj (str, x) => St.lookupFunctorByName (x, unwind' str) | _ => raise Fail "Corify of fancy functor application [2]" - val (fmods, xa, na, body) = unwind str1 + val (xa, na, body) = unwind str1 val (ds1, {inner = inner', outer}) = corifyStr mods (str2, st) - val mods' = case #1 str2 of - L.StrConst _ => fmods @ mods - | _ => - let - val ast = unwind' str2 - in - fmods @ St.name ast - end - - val (ds2, {inner, outer}) = corifyStr mods' (body, St.bindStr outer xa na inner') + val (ds2, {inner, outer}) = corifyStr mods (body, St.bindStr outer xa na inner') in (ds1 @ ds2, {inner = St.bindStr inner xa na inner', outer = outer}) end -- cgit v1.2.3 From 4f82b8197a0e0b520882c0173f321bd948fc7b50 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 24 Oct 2008 16:47:18 -0400 Subject: Transactions seem to be working --- .hgignore | 2 ++ src/c/driver.c | 56 ++++++++++++++++++++++++++++++++++++++++- src/cjr_print.sml | 75 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/aborter.sql | 3 +++ tests/aborter.ur | 5 ++++ tests/aborter.urp | 4 +++ 6 files changed, 144 insertions(+), 1 deletion(-) create mode 100644 tests/aborter.sql create mode 100644 tests/aborter.ur create mode 100644 tests/aborter.urp diff --git a/.hgignore b/.hgignore index f6368700..8c3417d4 100644 --- a/.hgignore +++ b/.hgignore @@ -24,3 +24,5 @@ src/config.sml demo/out/*.html demo/demo.* + +*.sql diff --git a/src/c/driver.c b/src/c/driver.c index 09478270..db982d96 100644 --- a/src/c/driver.c +++ b/src/c/driver.c @@ -51,6 +51,24 @@ static pthread_cond_t queue_cond = PTHREAD_COND_INITIALIZER; #define MAX_RETRIES 5 +int uw_db_begin(uw_context); +int uw_db_commit(uw_context); +int uw_db_rollback(uw_context); + +static int try_rollback(uw_context ctx) { + int r = uw_db_rollback(ctx); + + if (r) { + printf("Error running SQL ROLLBACK\n"); + uw_reset(ctx); + uw_write(ctx, "HTTP/1.1 500 Internal Server Error\n\r"); + uw_write(ctx, "Content-type: text/plain\r\n\r\n"); + uw_write(ctx, "Error running SQL ROLLBACK\n"); + } + + return r; +} + static void *worker(void *data) { int me = *(int *)data, retries_left = MAX_RETRIES; uw_context ctx = uw_init(1024, 0); @@ -116,6 +134,7 @@ static void *worker(void *data) { *back = 0; if (s = strstr(buf, "\r\n\r\n")) { + failure_kind fk; char *cmd, *path, path_copy[uw_bufsize+1], *inputs; *s = 0; @@ -169,7 +188,20 @@ static void *worker(void *data) { printf("Serving URI %s....\n", path); while (1) { - failure_kind fk; + if (uw_db_begin(ctx)) { + printf("Error running SQL BEGIN\n"); + if (retries_left) + --retries_left; + else { + fk = FATAL; + uw_reset(ctx); + uw_write(ctx, "HTTP/1.1 500 Internal Server Error\n\r"); + uw_write(ctx, "Content-type: text/plain\r\n\r\n"); + uw_write(ctx, "Error running SQL BEGIN\n"); + + break; + } + } uw_write(ctx, "HTTP/1.1 200 OK\r\n"); uw_write(ctx, "Content-type: text/html\r\n\r\n"); @@ -179,6 +211,17 @@ static void *worker(void *data) { fk = uw_begin(ctx, path_copy); if (fk == SUCCESS) { uw_write(ctx, ""); + + if (uw_db_commit(ctx)) { + fk = FATAL; + + printf("Error running SQL COMMIT\n"); + uw_reset(ctx); + uw_write(ctx, "HTTP/1.1 500 Internal Server Error\n\r"); + uw_write(ctx, "Content-type: text/plain\r\n\r\n"); + uw_write(ctx, "Error running SQL COMMIT\n"); + } + break; } else if (fk == BOUNDED_RETRY) { if (retries_left) { @@ -194,6 +237,10 @@ static void *worker(void *data) { uw_write(ctx, "Fatal error (out of retries): "); uw_write(ctx, uw_error_message(ctx)); uw_write(ctx, "\n"); + + try_rollback(ctx); + + break; } } else if (fk == UNLIMITED_RETRY) printf("Error triggers unlimited retry: %s\n", uw_error_message(ctx)); @@ -207,6 +254,8 @@ static void *worker(void *data) { uw_write(ctx, uw_error_message(ctx)); uw_write(ctx, "\n"); + try_rollback(ctx); + break; } else { printf("Unknown uw_handle return code!\n"); @@ -216,10 +265,15 @@ static void *worker(void *data) { uw_write(ctx, "Content-type: text/plain\r\n\r\n"); uw_write(ctx, "Unknown uw_handle return code!\n"); + try_rollback(ctx); + break; } uw_reset_keep_request(ctx); + + if (try_rollback(ctx)) + break; } uw_send(ctx, sock); diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 089f98a1..7d74376e 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1268,6 +1268,75 @@ fun p_decl env (dAll as (d, _) : decl) = string "PQfinish(uw_get_db(ctx));", newline, string "}", + newline, + newline, + + string "int uw_db_begin(uw_context ctx) {", + newline, + string "PGconn *conn = uw_get_db(ctx);", + newline, + string "PGresult *res = PQexec(conn, \"BEGIN\");", + newline, + newline, + string "if (res == NULL) return 1;", + newline, + newline, + string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", + box [string "PQclear(res);", + newline, + string "return 1;", + newline], + string "}", + newline, + string "return 0;", + newline, + string "}", + newline, + newline, + + string "int uw_db_commit(uw_context ctx) {", + newline, + string "PGconn *conn = uw_get_db(ctx);", + newline, + string "PGresult *res = PQexec(conn, \"COMMIT\");", + newline, + newline, + string "if (res == NULL) return 1;", + newline, + newline, + string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", + box [string "PQclear(res);", + newline, + string "return 1;", + newline], + string "}", + newline, + string "return 0;", + newline, + string "}", + newline, + newline, + + string "int uw_db_rollback(uw_context ctx) {", + newline, + string "PGconn *conn = uw_get_db(ctx);", + newline, + string "PGresult *res = PQexec(conn, \"ROLLBACK\");", + newline, + newline, + string "if (res == NULL) return 1;", + newline, + newline, + string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", + box [string "PQclear(res);", + newline, + string "return 1;", + newline], + string "}", + newline, + string "return 0;", + newline, + string "}", newline] | DPreparedStatements ss => @@ -2158,6 +2227,12 @@ fun p_file env (ds, ps) = else box [newline, string "void uw_db_init(uw_context ctx) { };", + newline, + string "int uw_db_begin(uw_context ctx) { return 0; };", + newline, + string "int uw_db_commit(uw_context ctx) { return 0; };", + newline, + string "int uw_db_rollback(uw_context ctx) { return 0; };", newline]] end diff --git a/tests/aborter.sql b/tests/aborter.sql new file mode 100644 index 00000000..ab6110fc --- /dev/null +++ b/tests/aborter.sql @@ -0,0 +1,3 @@ +CREATE TABLE uw_Aborter_t(uw_a int8 NOT NULL); + + \ No newline at end of file diff --git a/tests/aborter.ur b/tests/aborter.ur new file mode 100644 index 00000000..0921bdfc --- /dev/null +++ b/tests/aborter.ur @@ -0,0 +1,5 @@ +table t : {A : int} + +fun main () : transaction page = + () <- dml (INSERT INTO t (A) VALUES (0)); + return (error No way, Jose!) diff --git a/tests/aborter.urp b/tests/aborter.urp new file mode 100644 index 00000000..fc1925ae --- /dev/null +++ b/tests/aborter.urp @@ -0,0 +1,4 @@ +database dbname=aborter +sql aborter.sql + +aborter -- cgit v1.2.3 From 6e9d4b27c527465c6df34d35e4d85dc3162db7c9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 24 Oct 2008 17:30:07 -0400 Subject: Properly freeing libpq results on errors --- demo/sql.urp | 1 + include/urweb.h | 25 +++++++++++++------------ src/c/urweb.c | 44 ++++++++++++++++++++++++++++++++++++++++++++ src/cjr_print.sml | 4 +++- tests/aborter2.ur | 7 +++++++ tests/aborter2.urp | 5 +++++ 6 files changed, 73 insertions(+), 13 deletions(-) create mode 100644 tests/aborter2.ur create mode 100644 tests/aborter2.urp diff --git a/demo/sql.urp b/demo/sql.urp index 7894da95..06fbbd24 100644 --- a/demo/sql.urp +++ b/demo/sql.urp @@ -1,3 +1,4 @@ +debug database dbname=test sql sql.sql diff --git a/include/urweb.h b/include/urweb.h index 5a6c7178..6ac7df15 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -19,6 +19,8 @@ failure_kind uw_begin(uw_context, char *path); __attribute__((noreturn)) void uw_error(uw_context, failure_kind, const char *fmt, ...); char *uw_error_message(uw_context); +void uw_push_cleanup(uw_context, void (*func)(void *), void *arg); +void uw_pop_cleanup(uw_context); void *uw_malloc(uw_context, size_t); void uw_begin_region(uw_context); @@ -38,29 +40,28 @@ 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); -void uw_Basis_htmlifyInt_w(uw_context, uw_Basis_int); -void uw_Basis_htmlifyFloat_w(uw_context, uw_Basis_float); -void uw_Basis_htmlifyString_w(uw_context, uw_Basis_string); -void uw_Basis_htmlifyBool_w(uw_context, uw_Basis_bool); +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); char *uw_Basis_attrifyInt(uw_context, uw_Basis_int); char *uw_Basis_attrifyFloat(uw_context, uw_Basis_float); char *uw_Basis_attrifyString(uw_context, uw_Basis_string); -void uw_Basis_attrifyInt_w(uw_context, uw_Basis_int); -void uw_Basis_attrifyFloat_w(uw_context, uw_Basis_float); -void uw_Basis_attrifyString_w(uw_context, uw_Basis_string); - +uw_unit uw_Basis_attrifyInt_w(uw_context, uw_Basis_int); +uw_unit uw_Basis_attrifyFloat_w(uw_context, uw_Basis_float); +uw_unit uw_Basis_attrifyString_w(uw_context, uw_Basis_string); char *uw_Basis_urlifyInt(uw_context, uw_Basis_int); char *uw_Basis_urlifyFloat(uw_context, uw_Basis_float); char *uw_Basis_urlifyString(uw_context, uw_Basis_string); char *uw_Basis_urlifyBool(uw_context, uw_Basis_bool); -void uw_Basis_urlifyInt_w(uw_context, uw_Basis_int); -void uw_Basis_urlifyFloat_w(uw_context, uw_Basis_float); -void uw_Basis_urlifyString_w(uw_context, uw_Basis_string); -void uw_Basis_urlifyBool_w(uw_context, uw_Basis_bool); +uw_unit uw_Basis_urlifyInt_w(uw_context, uw_Basis_int); +uw_unit uw_Basis_urlifyFloat_w(uw_context, uw_Basis_float); +uw_unit uw_Basis_urlifyString_w(uw_context, uw_Basis_string); +uw_unit uw_Basis_urlifyBool_w(uw_context, uw_Basis_bool); uw_Basis_int uw_Basis_unurlifyInt(uw_context, char **); uw_Basis_float uw_Basis_unurlifyFloat(uw_context, char **); diff --git a/src/c/urweb.c b/src/c/urweb.c index d4fd1844..039ba119 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -15,6 +15,11 @@ typedef struct regions { struct regions *next; } regions; +typedef struct { + void (*func)(void*); + void *arg; +} cleanup; + struct uw_context { char *page, *page_front, *page_back; char *heap, *heap_front, *heap_back; @@ -26,6 +31,8 @@ struct uw_context { regions *regions; + cleanup *cleanup, *cleanup_front, *cleanup_back; + char error_message[ERROR_BUF_LEN]; }; @@ -46,6 +53,8 @@ uw_context uw_init(size_t page_len, size_t heap_len) { ctx->regions = NULL; + ctx->cleanup_front = ctx->cleanup_back = ctx->cleanup = malloc(0); + ctx->error_message[0] = 0; return ctx; @@ -63,6 +72,7 @@ void uw_free(uw_context ctx) { free(ctx->page); free(ctx->heap); free(ctx->inputs); + free(ctx->cleanup); free(ctx); } @@ -70,6 +80,7 @@ void uw_reset_keep_request(uw_context ctx) { ctx->page_front = ctx->page; ctx->heap_front = ctx->heap; ctx->regions = NULL; + ctx->cleanup_front = ctx->cleanup; ctx->error_message[0] = 0; } @@ -78,6 +89,7 @@ void uw_reset_keep_error_message(uw_context ctx) { ctx->page_front = ctx->page; ctx->heap_front = ctx->heap; ctx->regions = NULL; + ctx->cleanup_front = ctx->cleanup; } void uw_reset(uw_context ctx) { @@ -107,14 +119,46 @@ failure_kind uw_begin(uw_context ctx, char *path) { } __attribute__((noreturn)) void uw_error(uw_context ctx, failure_kind fk, const char *fmt, ...) { + cleanup *cl; + va_list ap; va_start(ap, fmt); vsnprintf(ctx->error_message, ERROR_BUF_LEN, fmt, ap); + for (cl = ctx->cleanup; cl < ctx->cleanup_front; ++cl) + cl->func(cl->arg); + + ctx->cleanup_front = ctx->cleanup; + longjmp(ctx->jmp_buf, fk); } +void uw_push_cleanup(uw_context ctx, void (*func)(void *), void *arg) { + if (ctx->cleanup_front >= ctx->cleanup_back) { + int len = ctx->cleanup_back - ctx->cleanup, newLen; + if (len == 0) + newLen = 1; + else + newLen *= 2; + ctx->cleanup = realloc(ctx->cleanup, newLen); + ctx->cleanup_front = ctx->cleanup + len; + ctx->cleanup_back = ctx->cleanup + newLen; + } + + ctx->cleanup_front->func = func; + ctx->cleanup_front->arg = arg; + ++ctx->cleanup_front; +} + +void uw_pop_cleanup(uw_context ctx) { + if (ctx->cleanup_front == ctx->cleanup) + uw_error(ctx, FATAL, "Attempt to pop from empty cleanup action stack"); + + --ctx->cleanup_front; + ctx->cleanup_front->func(ctx->cleanup_front->arg); +} + char *uw_error_message(uw_context ctx) { return ctx->error_message; } diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 7d74376e..26f6149e 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -850,6 +850,8 @@ fun p_exp' par env (e, loc) = string "uw_end_region(ctx);", newline, + string "uw_push_cleanup(ctx, (void (*)(void *))PQclear, res);", + newline, string "n = PQntuples(res);", newline, string "for (i = 0; i < n; ++i) {", @@ -906,7 +908,7 @@ fun p_exp' par env (e, loc) = string "}", newline, newline, - string "PQclear(res);", + string "uw_pop_cleanup(ctx);", newline, if wontLeakAnything then box [string "uw_end_region(ctx);", diff --git a/tests/aborter2.ur b/tests/aborter2.ur new file mode 100644 index 00000000..a7270ba1 --- /dev/null +++ b/tests/aborter2.ur @@ -0,0 +1,7 @@ +table t : { X : int } + +fun main () : transaction page = + v <- query (SELECT * FROM t) + (fn r (_ : int) => return (error Shot down!)) + 0; + return Result: {[v]} diff --git a/tests/aborter2.urp b/tests/aborter2.urp new file mode 100644 index 00000000..edc6c7da --- /dev/null +++ b/tests/aborter2.urp @@ -0,0 +1,5 @@ +debug +database dbname=aborter +sql aborter2.sql + +aborter2 -- cgit v1.2.3 From f5aed55553fddedd52105461e49411bb48e34de3 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 24 Oct 2008 17:35:33 -0400 Subject: Remove debug print for optional inputs --- src/c/urweb.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/c/urweb.c b/src/c/urweb.c index 039ba119..174185da 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -193,7 +193,7 @@ char *uw_get_optional_input(uw_context ctx, int n) { uw_error(ctx, FATAL, "Negative input index %d", n); if (n >= uw_inputs_len) uw_error(ctx, FATAL, "Out-of-bounds input index %d", n); - printf("[%d] = %s\n", n, ctx->inputs[n]); + //printf("[%d] = %s\n", n, ctx->inputs[n]); return (ctx->inputs[n] == NULL ? "" : ctx->inputs[n]); } -- cgit v1.2.3 From 3eb7517cc65f6767fad0f2e2a1984106c40214a5 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 24 Oct 2008 17:39:47 -0400 Subject: Add 'package' make target; add LICENSE --- LICENSE | 25 ++++++++++++++++++++++ Makefile | 71 ------------------------------------------------------------- Makefile.in | 5 ++++- 3 files changed, 29 insertions(+), 72 deletions(-) create mode 100644 LICENSE delete mode 100644 Makefile diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..0c963687 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +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. diff --git a/Makefile b/Makefile deleted file mode 100644 index 8e65ea08..00000000 --- a/Makefile +++ /dev/null @@ -1,71 +0,0 @@ -BIN := /usr/local/bin -LIB := /usr/local/lib/urweb -INCLUDE := /usr/local/include/urweb -SITELISP := /usr/local/share/emacs/site-lisp/urweb-mode - -LIB_UR := $(LIB)/ur -LIB_C := $(LIB)/c - -all: smlnj mlton c - -.PHONY: all smlnj mlton c clean install - -smlnj: src/urweb.cm -mlton: bin/urweb -c: clib/urweb.o clib/driver.o - -clean: - rm -f src/*.mlton.grm.* src/*.mlton.lex.* \ - src/urweb.cm src/urweb.mlb \ - clib/*.o - rm -rf .cm src/.cm - -clib/urweb.o: src/c/urweb.c - gcc -O3 -I include -c src/c/urweb.c -o clib/urweb.o - -clib/driver.o: src/c/driver.c - gcc -O3 -I include -c src/c/driver.c -o clib/driver.o - -src/urweb.cm: src/prefix.cm src/sources - cat src/prefix.cm src/sources \ - >src/urweb.cm - -src/urweb.mlb: src/prefix.mlb src/sources src/suffix.mlb - cat src/prefix.mlb src/sources src/suffix.mlb \ - | sed 's/^\(.*\).grm$$/\1.mlton.grm.sig\n\1.mlton.grm.sml/' \ - | sed 's/^\(.*\).lex$$/\1.mlton.lex.sml/' \ - >src/urweb.mlb - -%.mlton.lex: %.lex - cp $< $@ -%.mlton.grm: %.grm - cp $< $@ - -%.mlton.lex.sml: %.mlton.lex - mllex $< - -%.mlton.grm.sig %.mlton.grm.sml: %.mlton.grm - mlyacc $< - -MLTON := mlton - -ifdef DEBUG - MLTON += -const 'Exn.keepHistory true' -endif - -bin/urweb: src/urweb.mlb src/*.sig src/*.sml \ - src/urweb.mlton.lex.sml \ - src/urweb.mlton.grm.sig src/urweb.mlton.grm.sml - $(MLTON) -output $@ src/urweb.mlb - -install: - cp bin/urweb $(BIN)/ - mkdir -p $(LIB_UR) - cp lib/*.urs $(LIB_UR)/ - cp lib/*.ur $(LIB_UR)/ - mkdir -p $(LIB_C) - cp clib/*.o $(LIB_C)/ - mkdir -p $(INCLUDE) - cp include/*.h $(INCLUDE)/ - mkdir -p $(SITELISP) - cp src/elisp/*.el $(SITELISP)/ diff --git a/Makefile.in b/Makefile.in index 66da550e..f85b851c 100644 --- a/Makefile.in +++ b/Makefile.in @@ -8,7 +8,7 @@ LIB_C := $(LIB)/c all: smlnj mlton c -.PHONY: all smlnj mlton c clean install +.PHONY: all smlnj mlton c clean install package smlnj: src/urweb.cm mlton: bin/urweb @@ -69,3 +69,6 @@ install: cp include/*.h $(INCLUDE)/ mkdir -p $(SITELISP) cp src/elisp/*.el $(SITELISP)/ + +package: + hg archive -t tgz -X tests /tmp/urweb.tgz -- cgit v1.2.3 From 1d85b75e5d7d18a961c14bfdf38aee339f4f2e05 Mon Sep 17 00:00:00 2001 From: adamc Date: Fri, 24 Oct 2008 19:59:17 -0400 Subject: Make *_w function prototypes match header file --- src/c/urweb.c | 62 +++++++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 43 insertions(+), 19 deletions(-) diff --git a/src/c/urweb.c b/src/c/urweb.c index 174185da..3fa4d19d 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -140,7 +140,7 @@ void uw_push_cleanup(uw_context ctx, void (*func)(void *), void *arg) { if (len == 0) newLen = 1; else - newLen *= 2; + newLen = len * 2; ctx->cleanup = realloc(ctx->cleanup, newLen); ctx->cleanup_front = ctx->cleanup + len; ctx->cleanup_back = ctx->cleanup + newLen; @@ -279,14 +279,16 @@ static void uw_check(uw_context ctx, size_t extra) { char *new_page; next = ctx->page_back - ctx->page; - if (next == 0) - next = 1; - for (; next < desired; next *= 2); + if (next < desired) { + if (next == 0) + next = 1; + for (; next < desired; next *= 2); - new_page = realloc(ctx->page, next); - ctx->page_front = new_page + (ctx->page_front - ctx->page); - ctx->page_back = new_page + next; - ctx->page = new_page; + new_page = realloc(ctx->page, next); + ctx->page_front = new_page + (ctx->page_front - ctx->page); + ctx->page_back = new_page + next; + ctx->page = new_page; + } } static void uw_writec_unsafe(uw_context ctx, char c) { @@ -369,20 +371,24 @@ static void uw_Basis_attrifyInt_w_unsafe(uw_context ctx, uw_Basis_int n) { ctx->page_front += len; } -void uw_Basis_attrifyInt_w(uw_context ctx, uw_Basis_int n) { +uw_unit uw_Basis_attrifyInt_w(uw_context ctx, uw_Basis_int n) { uw_check(ctx, INTS_MAX); uw_Basis_attrifyInt_w_unsafe(ctx, n); + + return uw_unit_v; } -void uw_Basis_attrifyFloat_w(uw_context ctx, uw_Basis_float n) { +uw_unit uw_Basis_attrifyFloat_w(uw_context ctx, uw_Basis_float n) { int len; uw_check(ctx, FLOATS_MAX); sprintf(ctx->page_front, "%g%n", n, &len); ctx->page_front += len; + + return uw_unit_v; } -void uw_Basis_attrifyString_w(uw_context ctx, uw_Basis_string s) { +uw_unit uw_Basis_attrifyString_w(uw_context ctx, uw_Basis_string s) { uw_check(ctx, strlen(s) * 6); for (; *s; s++) { @@ -400,6 +406,8 @@ void uw_Basis_attrifyString_w(uw_context ctx, uw_Basis_string s) { uw_writec_unsafe(ctx, ';'); } } + + return uw_unit_v; } @@ -462,20 +470,24 @@ static void uw_Basis_urlifyInt_w_unsafe(uw_context ctx, uw_Basis_int n) { ctx->page_front += len; } -void uw_Basis_urlifyInt_w(uw_context ctx, uw_Basis_int n) { +uw_unit uw_Basis_urlifyInt_w(uw_context ctx, uw_Basis_int n) { uw_check(ctx, INTS_MAX); uw_Basis_urlifyInt_w_unsafe(ctx, n); + + return uw_unit_v; } -void uw_Basis_urlifyFloat_w(uw_context ctx, uw_Basis_float n) { +uw_unit uw_Basis_urlifyFloat_w(uw_context ctx, uw_Basis_float n) { int len; uw_check(ctx, FLOATS_MAX); sprintf(ctx->page_front, "%g%n", n, &len); ctx->page_front += len; + + return uw_unit_v; } -void uw_Basis_urlifyString_w(uw_context ctx, uw_Basis_string s) { +uw_unit uw_Basis_urlifyString_w(uw_context ctx, uw_Basis_string s) { uw_check(ctx, strlen(s) * 3); for (; *s; s++) { @@ -490,13 +502,17 @@ void uw_Basis_urlifyString_w(uw_context ctx, uw_Basis_string s) { ctx->page_front += 3; } } + + return uw_unit_v; } -void uw_Basis_urlifyBool_w(uw_context ctx, uw_Basis_bool b) { +uw_unit uw_Basis_urlifyBool_w(uw_context ctx, uw_Basis_bool b) { if (b == uw_Basis_False) uw_writec(ctx, '0'); else uw_writec(ctx, '1'); + + return uw_unit_v; } @@ -597,12 +613,14 @@ char *uw_Basis_htmlifyInt(uw_context ctx, uw_Basis_int n) { return r; } -void uw_Basis_htmlifyInt_w(uw_context ctx, uw_Basis_int n) { +uw_unit uw_Basis_htmlifyInt_w(uw_context ctx, uw_Basis_int n) { int len; uw_check(ctx, INTS_MAX); sprintf(ctx->page_front, "%lld%n", n, &len); ctx->page_front += len; + + return uw_unit_v; } char *uw_Basis_htmlifyFloat(uw_context ctx, uw_Basis_float n) { @@ -616,12 +634,14 @@ char *uw_Basis_htmlifyFloat(uw_context ctx, uw_Basis_float n) { return r; } -void uw_Basis_htmlifyFloat_w(uw_context ctx, uw_Basis_float n) { +uw_unit uw_Basis_htmlifyFloat_w(uw_context ctx, uw_Basis_float n) { int len; uw_check(ctx, FLOATS_MAX); sprintf(ctx->page_front, "%g%n", n, &len); ctx->page_front += len; + + return uw_unit_v; } char *uw_Basis_htmlifyString(uw_context ctx, uw_Basis_string s) { @@ -657,7 +677,7 @@ char *uw_Basis_htmlifyString(uw_context ctx, uw_Basis_string s) { return r; } -void uw_Basis_htmlifyString_w(uw_context ctx, uw_Basis_string s) { +uw_unit uw_Basis_htmlifyString_w(uw_context ctx, uw_Basis_string s) { uw_check(ctx, strlen(s) * 6); for (; *s; s++) { @@ -680,6 +700,8 @@ void uw_Basis_htmlifyString_w(uw_context ctx, uw_Basis_string s) { } } } + + return uw_unit_v; } uw_Basis_string uw_Basis_htmlifyBool(uw_context ctx, uw_Basis_bool b) { @@ -689,7 +711,7 @@ uw_Basis_string uw_Basis_htmlifyBool(uw_context ctx, uw_Basis_bool b) { return "True"; } -void uw_Basis_htmlifyBool_w(uw_context ctx, uw_Basis_bool b) { +uw_unit uw_Basis_htmlifyBool_w(uw_context ctx, uw_Basis_bool b) { if (b == uw_Basis_False) { uw_check(ctx, 6); strcpy(ctx->page_front, "False"); @@ -699,6 +721,8 @@ void uw_Basis_htmlifyBool_w(uw_context ctx, uw_Basis_bool b) { strcpy(ctx->page_front, "True"); ctx->page_front += 4; } + + return uw_unit_v; } uw_Basis_string uw_Basis_strcat(uw_context ctx, uw_Basis_string s1, uw_Basis_string s2) { -- cgit v1.2.3 From 1ba5a166755794de2a31af5cdcb1d6ea95f637b9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 25 Oct 2008 12:07:10 -0400 Subject: Use configure --prefix --- configure | 12 ++++++++---- configure.ac | 12 ++++++++---- 2 files changed, 16 insertions(+), 8 deletions(-) diff --git a/configure b/configure index 25a703df..e205575b 100755 --- a/configure +++ b/configure @@ -1632,20 +1632,24 @@ diagnostic() { true "$@" } +if test $prefix = "NONE"; then + prefix=/usr/local +fi + if test -z $BIN; then - BIN=/usr/local/bin + BIN=$prefix/bin fi if test -z $LIB; then - LIB=/usr/local/lib/urweb + LIB=$prefix/lib/urweb fi if test -z $INCLUDE; then - INCLUDE=/usr/local/include/urweb + INCLUDE=$prefix/include/urweb fi if test -z $SITELISP; then - SITELISP=/usr/local/share/emacs/site-lisp/urweb-mode + SITELISP=$prefix/share/emacs/site-lisp/urweb-mode fi diff --git a/configure.ac b/configure.ac index a0455358..dee2bc1b 100644 --- a/configure.ac +++ b/configure.ac @@ -25,20 +25,24 @@ diagnostic() { true "$@" } +if test [$prefix = "NONE"]; then + prefix=/usr/local +fi + if test [-z $BIN]; then - BIN=/usr/local/bin + BIN=$prefix/bin fi if test [-z $LIB]; then - LIB=/usr/local/lib/urweb + LIB=$prefix/lib/urweb fi if test [-z $INCLUDE]; then - INCLUDE=/usr/local/include/urweb + INCLUDE=$prefix/include/urweb fi if test [-z $SITELISP]; then - SITELISP=/usr/local/share/emacs/site-lisp/urweb-mode + SITELISP=$prefix/share/emacs/site-lisp/urweb-mode fi -- cgit v1.2.3 From ca867a54a45d6d87d04a99994be11206c9b27388 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 25 Oct 2008 12:18:33 -0400 Subject: mkdir -p BIN --- Makefile.in | 1 + 1 file changed, 1 insertion(+) diff --git a/Makefile.in b/Makefile.in index f85b851c..ec7af282 100644 --- a/Makefile.in +++ b/Makefile.in @@ -59,6 +59,7 @@ bin/urweb: src/urweb.mlb src/*.sig src/*.sml \ $(MLTON) -output $@ src/urweb.mlb install: + mkdir -p $(BIN) cp bin/urweb $(BIN)/ mkdir -p $(LIB_UR) cp lib/*.urs $(LIB_UR)/ -- cgit v1.2.3 From 978e1439b5b985f1483f7eb1edfc954e3f2bf1c2 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 25 Oct 2008 18:58:45 -0400 Subject: Change 'sed' invocation to work in OSX --- Makefile.in | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Makefile.in b/Makefile.in index ec7af282..364b230f 100644 --- a/Makefile.in +++ b/Makefile.in @@ -32,7 +32,7 @@ src/urweb.cm: src/prefix.cm src/sources src/urweb.mlb: src/prefix.mlb src/sources src/suffix.mlb cat src/prefix.mlb src/sources src/suffix.mlb \ - | sed 's/^\(.*\).grm$$/\1.mlton.grm.sig\n\1.mlton.grm.sml/' \ + | sed 's/^\(.*\).grm$$/\1.mlton.grm.sig:\1.mlton.grm.sml/; y/:/\n/' \ | sed 's/^\(.*\).lex$$/\1.mlton.lex.sml/' \ >src/urweb.mlb -- cgit v1.2.3 From 5badaf182a69fc7d67f9ae2e5a0a8e5bf7edea36 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 26 Oct 2008 08:41:17 -0400 Subject: Avoid using libpq when unneeded --- src/cjr_print.sml | 15 ++++++++++++--- src/compiler.sig | 2 +- src/compiler.sml | 13 ++++++++++--- 3 files changed, 23 insertions(+), 7 deletions(-) diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 26f6149e..e26293ab 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1341,6 +1341,7 @@ fun p_decl env (dAll as (d, _) : decl) = string "}", newline] + | DPreparedStatements [] => box [] | DPreparedStatements ss => box [string "static void uw_db_prepare(uw_context ctx) {", newline, @@ -2182,6 +2183,8 @@ fun p_file env (ds, ps) = end) sequences, string "}"] + + val hasDb = List.exists (fn (DDatabase _, _) => true | _ => false) ds in box [string "#include ", newline, @@ -2191,8 +2194,11 @@ fun p_file env (ds, ps) = newline, string "#include ", newline, - string "#include ", - newline, + if hasDb then + box [string "#include ", + newline] + else + box [], newline, string "#include \"", string (OS.Path.joinDirFile {dir = Config.includ, @@ -2222,7 +2228,10 @@ fun p_file env (ds, ps) = string "}", newline, newline, - validate, + if hasDb then + validate + else + box [], newline, if List.exists (fn (DDatabase _, _) => true | _ => false) ds then box [] diff --git a/src/compiler.sig b/src/compiler.sig index f0914d0f..0c95934a 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -38,7 +38,7 @@ signature COMPILER = sig debug : bool } val compile : string -> unit - val compileC : {cname : string, oname : string, ename : string} -> unit + val compileC : {cname : string, oname : string, ename : string, libs : string} -> unit type ('src, 'dst) phase type ('src, 'dst) transform diff --git a/src/compiler.sml b/src/compiler.sml index df4ee48d..5d48287b 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -506,13 +506,13 @@ val sqlify = { val toSqlify = transform sqlify "sqlify" o toMono_opt2 -fun compileC {cname, oname, ename} = +fun compileC {cname, oname, ename, libs} = let val urweb_o = clibFile "urweb.o" val driver_o = clibFile "driver.o" val compile = "gcc -Wstrict-prototypes -Werror -O3 -I include -c " ^ cname ^ " -o " ^ oname - val link = "gcc -Werror -O3 -lm -pthread -lpq " ^ urweb_o ^ " " ^ oname ^ " " ^ driver_o ^ " -o " ^ ename + val link = "gcc -Werror -O3 -lm -pthread " ^ libs ^ " " ^ urweb_o ^ " " ^ oname ^ " " ^ driver_o ^ " -o " ^ ename in if not (OS.Process.isSuccess (OS.Process.system compile)) then print "C compilation failed\n" @@ -553,6 +553,13 @@ fun compile job = let val outf = TextIO.openOut cname val s = TextIOPP.openOut {dst = outf, wid = 80} + + val hasDb = List.exists (fn (Cjr.DDatabase _, _) => true | _ => false) (#1 file) + val libs = + if hasDb then + "-lpq" + else + "" in Print.fprint s (CjrPrint.p_file CjrEnv.empty file); TextIO.output1 (outf, #"\n"); @@ -569,7 +576,7 @@ fun compile job = TextIO.closeOut outf end; - compileC {cname = cname, oname = oname, ename = ename}; + compileC {cname = cname, oname = oname, ename = ename, libs = libs}; cleanup () end -- cgit v1.2.3 From 794a3ad4e4713e74d2118d8f24b09ef4d35bd34f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Mon, 27 Oct 2008 08:16:19 -0400 Subject: Switch exit(1) call to uw_error() --- CHANGELOG | 12 ++++++++++++ src/cjr_print.sml | 10 +++------- 2 files changed, 15 insertions(+), 7 deletions(-) create mode 100644 CHANGELOG diff --git a/CHANGELOG b/CHANGELOG new file mode 100644 index 00000000..6b62d606 --- /dev/null +++ b/CHANGELOG @@ -0,0 +1,12 @@ +======== +20081027 +======== + +- On missing inputs, print an error message, but don't exit the web server. + +======== +20081026 +======== + +- Change 'sed' call to work on OSX. +- Avoid including or linking libpq files on apps that don't use SQL. diff --git a/src/cjr_print.sml b/src/cjr_print.sml index e26293ab..7c0fd73c 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1845,15 +1845,11 @@ fun p_file env (ds, ps) = string (Int.toString n), string ");", newline, - string "if (request == NULL) {", + string "if (request == NULL)", newline, - box [string "printf(\"Missing input ", + box [string "uw_error(ctx, FATAL, \"Missing input ", string x, - string "\\n\");", - newline, - string "exit(1);"], - newline, - string "}", + string "\");"], newline, string "uw_input_", p_ident x, -- cgit v1.2.3 From 5d118aafe9b7cecdb429836b61bb9fdf6e8fc24e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Mon, 27 Oct 2008 08:27:45 -0400 Subject: Remove need for '() <-' notation --- CHANGELOG | 1 + demo/crud.ur | 44 ++++++++++++++++++++++---------------------- demo/ref.ur | 8 ++++---- demo/refFun.ur | 2 +- demo/sql.ur | 8 ++++---- src/urweb.grm | 30 ++++++++++++++++++------------ 6 files changed, 50 insertions(+), 43 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 6b62d606..1c20780e 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -3,6 +3,7 @@ ======== - On missing inputs, print an error message, but don't exit the web server. +- Remove need for "() <-" notation. ======== 20081026 diff --git a/demo/crud.ur b/demo/crud.ur index 472de6d4..77fccf16 100644 --- a/demo/crud.ur +++ b/demo/crud.ur @@ -94,15 +94,15 @@ functor Make(M : sig and create (inputs : $(mapT2T sndTT M.cols)) = id <- nextval seq; - () <- dml (insert tab - (foldT2R2 [sndTT] [colMeta] - [fn cols => $(mapT2T (fn t :: (Type * Type) => - sql_exp [] [] [] t.1) cols)] - (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) - [[nm] ~ rest] => - fn input col acc => acc with nm = @sql_inject col.Inject (col.Parse input)) - {} [M.cols] inputs M.cols - with #Id = (SQL {id}))); + dml (insert tab + (foldT2R2 [sndTT] [colMeta] + [fn cols => $(mapT2T (fn t :: (Type * Type) => + sql_exp [] [] [] t.1) cols)] + (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) + [[nm] ~ rest] => + fn input col acc => acc with nm = @sql_inject col.Inject (col.Parse input)) + {} [M.cols] inputs M.cols + with #Id = (SQL {id}))); ls <- list (); return

    Inserted with ID {[id]}.

    @@ -111,18 +111,18 @@ functor Make(M : sig     and save (id : int) (inputs : $(mapT2T sndTT M.cols)) = - () <- dml (update [mapT2T fstTT M.cols] - (foldT2R2 [sndTT] [colMeta] - [fn cols => $(mapT2T (fn t :: (Type * Type) => - sql_exp [T = [Id = int] - ++ mapT2T fstTT M.cols] - [] [] t.1) cols)] - (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) - [[nm] ~ rest] => - fn input col acc => acc with nm = - @sql_inject col.Inject (col.Parse input)) - {} [M.cols] inputs M.cols) - tab (WHERE T.Id = {id})); + dml (update [mapT2T fstTT M.cols] + (foldT2R2 [sndTT] [colMeta] + [fn cols => $(mapT2T (fn t :: (Type * Type) => + sql_exp [T = [Id = int] + ++ mapT2T fstTT M.cols] + [] [] t.1) cols)] + (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) + [[nm] ~ rest] => + fn input col acc => acc with nm = + @sql_inject col.Inject (col.Parse input)) + {} [M.cols] inputs M.cols) + tab (WHERE T.Id = {id})); ls <- list (); return

    Saved!

    @@ -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/ref.ur b/demo/ref.ur index 089529e3..4030b6fa 100644 --- a/demo/ref.ur +++ b/demo/ref.ur @@ -13,15 +13,15 @@ fun main () = ir' <- IR.new 7; sr <- SR.new "hi"; - () <- IR.write ir' 10; + IR.write ir' 10; iv <- IR.read ir; iv' <- IR.read ir'; sv <- SR.read sr; - () <- IR.delete ir; - () <- IR.delete ir'; - () <- SR.delete sr; + IR.delete ir; + IR.delete ir'; + SR.delete sr; return {[iv]}, {[iv']}, {[sv]} diff --git a/demo/refFun.ur b/demo/refFun.ur index a090b297..d648f31e 100644 --- a/demo/refFun.ur +++ b/demo/refFun.ur @@ -10,7 +10,7 @@ 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 = diff --git a/demo/sql.ur b/demo/sql.ur index 9e9effff..43a69573 100644 --- a/demo/sql.ur +++ b/demo/sql.ur @@ -26,8 +26,8 @@ fun list () = and add r = - () <- dml (INSERT INTO t (A, B, C, D) - VALUES ({readError r.A}, {readError r.B}, {r.C}, {r.D})); + dml (INSERT INTO t (A, B, C, D) + VALUES ({readError r.A}, {readError r.B}, {r.C}, {r.D})); xml <- list (); return

    Row added.

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

    Row deleted.

    diff --git a/src/urweb.grm b/src/urweb.grm index 9a9081a3..4f470fa0 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -263,6 +263,7 @@ fun tagIn bt = | xmlOne of exp | tag of string * exp | tagHead of string * exp + | bind of string * con option * exp | earg of exp * con -> exp * con | eargp of exp * con -> exp * con @@ -668,20 +669,13 @@ eexp : eapps (eapps) (ECase (eexp1, [((PCon (["Basis"], "True", NONE), loc), eexp2), ((PCon (["Basis"], "False", NONE), loc), eexp3)]), loc) end) - | SYMBOL LARROW eexp SEMI eexp (let - val loc = s (SYMBOLleft, eexp2right) + | bind SEMI eexp (let + val loc = s (bindleft, eexpright) + val (v, to, e1) = bind val e = (EVar (["Basis"], "bind", Infer), loc) - val e = (EApp (e, eexp1), loc) + val e = (EApp (e, e1), loc) in - (EApp (e, (EAbs (SYMBOL, NONE, eexp2), loc)), loc) - end) - | UNIT LARROW eexp SEMI eexp (let - val loc = s (UNITleft, eexp2right) - val e = (EVar (["Basis"], "bind", Infer), loc) - val e = (EApp (e, eexp1), loc) - val t = (TRecord (CRecord [], loc), loc) - in - (EApp (e, (EAbs ("_", SOME t, eexp2), loc)), loc) + (EApp (e, (EAbs (v, to, eexp), loc)), loc) end) | eexp EQ eexp (native_op ("eq", eexp1, eexp2, s (eexp1left, eexp2right))) | eexp NE eexp (native_op ("ne", eexp1, eexp2, s (eexp1left, eexp2right))) @@ -699,6 +693,18 @@ eexp : eapps (eapps) | eexp WITH cterm EQ eexp (EWith (eexp1, cterm, eexp2), s (eexp1left, eexp2right)) +bind : SYMBOL LARROW eapps (SYMBOL, NONE, eapps) + | UNIT LARROW eapps (let + val loc = s (UNITleft, eappsright) + in + ("_", SOME (TRecord (CRecord [], loc), loc), eapps) + end) + | eapps (let + val loc = s (eappsleft, eappsright) + in + ("_", SOME (TRecord (CRecord [], loc), loc), eapps) + end) + eargs : earg (earg) | eargl (eargl) -- cgit v1.2.3 From e0f5b40bb999cf78e9ad479d8004cf00ed7b3059 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 28 Oct 2008 15:05:16 -0400 Subject: GCCARGS configure option --- CHANGELOG | 6 ++++++ configure | 6 +++++- configure.ac | 2 ++ src/compiler.sml | 2 +- src/config.sig | 2 ++ src/config.sml.in | 2 ++ 6 files changed, 18 insertions(+), 2 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 1c20780e..aca01ea7 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,9 @@ +======== +20081028 +======== + +- Add GCCARGS configure option + ======== 20081027 ======== diff --git a/configure b/configure index e205575b..e34c6b57 100755 --- a/configure +++ b/configure @@ -618,6 +618,7 @@ BIN LIB INCLUDE SITELISP +GCCARGS do_not_edit LIBOBJS LTLIBOBJS' @@ -1665,6 +1666,7 @@ do_not_edit="Do not edit this file. It was generated automatically from" + # finish the configure script and generate various files; ./configure # will apply variable substitutions to .in to generate ; # I find it useful to mark generated files as read-only so I don't @@ -2365,12 +2367,13 @@ BIN!$BIN$ac_delim LIB!$LIB$ac_delim INCLUDE!$INCLUDE$ac_delim SITELISP!$SITELISP$ac_delim +GCCARGS!$GCCARGS$ac_delim do_not_edit!$do_not_edit$ac_delim LIBOBJS!$LIBOBJS$ac_delim LTLIBOBJS!$LTLIBOBJS$ac_delim _ACEOF - if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 44; then + if test `sed -n "s/.*$ac_delim\$/X/p" conf$$subs.sed | grep -c X` = 45; then break elif $ac_last_try; then { { echo "$as_me:$LINENO: error: could not make $CONFIG_STATUS" >&5 @@ -2712,4 +2715,5 @@ Ur/Web configuration: lib directory: LIB $LIB include directory: INCLUDE $INCLUDE site-lisp directory: SITELISP $SITELISP + Extra GCC args: GCCARGS $GCCARGS EOF diff --git a/configure.ac b/configure.ac index dee2bc1b..25196f76 100644 --- a/configure.ac +++ b/configure.ac @@ -56,6 +56,7 @@ AC_SUBST(BIN) AC_SUBST(LIB) AC_SUBST(INCLUDE) AC_SUBST(SITELISP) +AC_SUBST(GCCARGS) AC_SUBST(do_not_edit) # finish the configure script and generate various files; ./configure @@ -98,4 +99,5 @@ Ur/Web configuration: lib directory: LIB $LIB include directory: INCLUDE $INCLUDE site-lisp directory: SITELISP $SITELISP + Extra GCC args: GCCARGS $GCCARGS EOF diff --git a/src/compiler.sml b/src/compiler.sml index 5d48287b..1f88705c 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -511,7 +511,7 @@ fun compileC {cname, oname, ename, libs} = val urweb_o = clibFile "urweb.o" val driver_o = clibFile "driver.o" - val compile = "gcc -Wstrict-prototypes -Werror -O3 -I include -c " ^ cname ^ " -o " ^ oname + val compile = "gcc " ^ Config.gccArgs ^ " -Wstrict-prototypes -Werror -O3 -I include -c " ^ cname ^ " -o " ^ oname val link = "gcc -Werror -O3 -lm -pthread " ^ libs ^ " " ^ urweb_o ^ " " ^ oname ^ " " ^ driver_o ^ " -o " ^ ename in if not (OS.Process.isSuccess (OS.Process.system compile)) then diff --git a/src/config.sig b/src/config.sig index 890bd9ab..6075482e 100644 --- a/src/config.sig +++ b/src/config.sig @@ -6,4 +6,6 @@ signature CONFIG = sig val libUr : string val libC : string + + val gccArgs : string end diff --git a/src/config.sml.in b/src/config.sml.in index d1eb5025..9e53986b 100644 --- a/src/config.sml.in +++ b/src/config.sml.in @@ -10,4 +10,6 @@ val libUr = OS.Path.joinDirFile {dir = lib, val libC = OS.Path.joinDirFile {dir = lib, file = "c"} +val gccArgs = "@GCCARGS@" + end -- 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 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(-) 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 bca91774855a83f677f1a53abd3081258dc3a95c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 30 Oct 2008 14:57:15 -0400 Subject: Reading timestamps from SQL --- src/c/urweb.c | 28 +++++++++++++++++++++------- src/cjr_print.sml | 2 ++ tests/time.ur | 10 +++++++++- tests/time.urp | 2 ++ 4 files changed, 34 insertions(+), 8 deletions(-) diff --git a/src/c/urweb.c b/src/c/urweb.c index 7a160637..df3ce6e1 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -728,6 +728,7 @@ uw_unit uw_Basis_htmlifyBool_w(uw_context ctx, uw_Basis_bool b) { } #define TIME_FMT "%x %X" +#define TIME_FMT_PG "%Y-%m-%d %T" uw_Basis_string uw_Basis_htmlifyTime(uw_context ctx, uw_Basis_time t) { size_t len; @@ -950,10 +951,10 @@ uw_Basis_bool *uw_Basis_stringToBool(uw_context ctx, uw_Basis_string s) { } uw_Basis_time *uw_Basis_stringToTime(uw_context ctx, uw_Basis_string s) { - char *end = strchr(s, 0); + char *dot = strchr(s, '.'), *end = strchr(s, 0); struct tm stm; - if (strptime(s, TIME_FMT, &stm) == end) { + 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; @@ -992,11 +993,24 @@ uw_Basis_bool uw_Basis_stringToBool_error(uw_context ctx, uw_Basis_string s) { } uw_Basis_time uw_Basis_stringToTime_error(uw_context ctx, uw_Basis_string s) { - char *end = strchr(s, 0); + char *dot = strchr(s, '.'), *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); + if (dot) { + *dot = 0; + if (strptime(s, TIME_FMT_PG, &stm)) { + *dot = '.'; + return mktime(&stm); + } + else { + *dot = '.'; + uw_error(ctx, FATAL, "Can't parse time: %s", s); + } + } + 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 7c0fd73c..01d71872 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -403,6 +403,7 @@ fun p_unsql wontLeakStrings env (tAll as (t, loc)) e = else 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") @@ -1395,6 +1396,7 @@ fun p_sqltype' env (tAll as (t, loc)) = | TFfi ("Basis", "float") => "float8" | TFfi ("Basis", "string") => "text" | TFfi ("Basis", "bool") => "bool" + | TFfi ("Basis", "time") => "timestamp" | _ => (ErrorMsg.errorAt loc "Don't know SQL equivalent of type"; Print.eprefaces' [("Type", p_typ env tAll)]; "ERROR") diff --git a/tests/time.ur b/tests/time.ur index 7b8b93ef..f6093dd3 100644 --- a/tests/time.ur +++ b/tests/time.ur @@ -1,4 +1,12 @@ +table t : { Id : int, Time : time } + val now : time = readError "10/30/08 14:35:42" val later : time = readError "10/30/08 14:37:42" -fun main () = return {[now]}, {[now = now]}, {[now = later]}, {[later < now]}, {[now < later]} +fun main () = + xml <- queryX (SELECT * FROM t) + (fn r => {[r.T.Id]}: {[r.T.Time]}
    ); + return + {xml} + {[now]}, {[now = now]}, {[now = later]}, {[later < now]}, {[now < later]} + diff --git a/tests/time.urp b/tests/time.urp index f48698e9..bfa87a0a 100644 --- a/tests/time.urp +++ b/tests/time.urp @@ -1,3 +1,5 @@ debug +database dbname=time +sql time.sql time -- 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(-) 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 7e90e2dd45c936519b6397a3ac9f8cb481ea6511 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 30 Oct 2008 15:16:37 -0400 Subject: Time MIN/MAX --- lib/top.ur | 8 ++++++++ lib/top.urs | 10 ++++++++++ tests/time.ur | 4 +++- 3 files changed, 21 insertions(+), 1 deletion(-) diff --git a/lib/top.ur b/lib/top.ur index 0bc345de..d36af3f3 100644 --- a/lib/top.ur +++ b/lib/top.ur @@ -157,3 +157,11 @@ fun oneOrNoRows (tables ::: {{Type}}) (exps ::: {Type}) query q (fn fs _ => return (Some fs)) None + +fun oneRow (tables ::: {{Type}}) (exps ::: {Type}) + (q : sql_query tables exps) [tables ~ exps] = + o <- oneOrNoRows q; + return (case o of + None => error Query returned no rows + | Some r => r) + diff --git a/lib/top.urs b/lib/top.urs index 22cebb16..6e9dda4e 100644 --- a/lib/top.urs +++ b/lib/top.urs @@ -116,3 +116,13 @@ val oneOrNoRows : tables ::: {{Type}} -> exps ::: {Type} [[nm] ~ acc] => [nm = $fields] ++ acc) [] tables)) + +val oneRow : tables ::: {{Type}} -> exps ::: {Type} + -> sql_query tables exps + -> fn [tables ~ exps] => + transaction + $(exps + ++ fold (fn nm (fields :: {Type}) acc + [[nm] ~ acc] => + [nm = $fields] ++ acc) + [] tables) diff --git a/tests/time.ur b/tests/time.ur index f66004a5..f81c59c3 100644 --- a/tests/time.ur +++ b/tests/time.ur @@ -7,7 +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); return {xml} - {[now]}, {[now = now]}, {[now = later]}, {[later < now]}, {[now < later]} + {[now]}, {[now = now]}, {[now = later]}, {[later < now]}, {[now < later]}
    + {[minMax.Min]}, {[minMax.Max]}     -- 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(-) 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 c6f6a629256d7292ae7c18428656eda4130391bd Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 30 Oct 2008 15:39:06 -0400 Subject: Don't inline case expressions --- src/mono_reduce.sml | 91 ++++++++++++++++++++++++++++------------------------- 1 file changed, 49 insertions(+), 42 deletions(-) diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index f88bea8f..07c7c5f5 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -351,49 +351,56 @@ fun exp env e = EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e, swapExpVars 0 e'), loc)) | ELet (x, t, e', b) => - if impure e' then - 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 => + let + fun trySub () = + case e' of + (ECase _, _) => e + | _ => #1 (reduceExp env (subExpInExp (0, e') b)) + in + if impure e' then + 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 - 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 - #1 (reduceExp env (subExpInExp (0, e') b)) - else - e - end - else - #1 (reduceExp env (subExpInExp (0, e') b)) + 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 + 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)) -- cgit v1.2.3 From 0e88aba4fcbcf9587c289a555315ec30a112a2f0 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 30 Oct 2008 16:58:54 -0400 Subject: Especialize --- lib/basis.urs | 3 + src/compiler.sig | 2 + src/compiler.sml | 9 ++- src/core_env.sig | 3 + src/core_env.sml | 29 +++++++++ src/core_util.sig | 5 ++ src/core_util.sml | 7 +++ src/especialize.sig | 32 ++++++++++ src/especialize.sml | 176 ++++++++++++++++++++++++++++++++++++++++++++++++++++ src/reduce.sml | 32 +--------- src/sources | 3 + 11 files changed, 270 insertions(+), 31 deletions(-) create mode 100644 src/especialize.sig create mode 100644 src/especialize.sml diff --git a/lib/basis.urs b/lib/basis.urs index 8992bc8c..0e6b9988 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -352,6 +352,9 @@ val tt : bodyTag [] val font : bodyTag [Size = int, Face = string] val h1 : bodyTag [] +val h2 : bodyTag [] +val h3 : bodyTag [] +val h4 : bodyTag [] val li : bodyTag [] val hr : bodyTag [] diff --git a/src/compiler.sig b/src/compiler.sig index 0c95934a..e26ec13c 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -61,6 +61,7 @@ signature COMPILER = sig val termination : (Elab.file, Elab.file) phase val explify : (Elab.file, Expl.file) phase val corify : (Expl.file, Core.file) phase + val especialize : (Core.file, Core.file) phase val shake : (Core.file, Core.file) phase val tag : (Core.file, Core.file) phase val reduce : (Core.file, Core.file) phase @@ -82,6 +83,7 @@ signature COMPILER = sig val toTermination : (string, Elab.file) transform val toExplify : (string, Expl.file) transform val toCorify : (string, Core.file) transform + val toEspecialize : (string, Core.file) transform val toShake1 : (string, Core.file) transform val toTag : (string, Core.file) transform val toReduce : (string, Core.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 1f88705c..4f1bce11 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -404,12 +404,19 @@ val corify = { val toCorify = transform corify "corify" o toExplify +val especialize = { + func = ESpecialize.specialize, + print = CorePrint.p_file CoreEnv.empty +} + +val toEspecialize = transform especialize "especialize" o toCorify + val shake = { func = Shake.shake, print = CorePrint.p_file CoreEnv.empty } -val toShake1 = transform shake "shake1" o toCorify +val toShake1 = transform shake "shake1" o toEspecialize val tag = { func = Tag.tag, diff --git a/src/core_env.sig b/src/core_env.sig index cdbf5946..98e345cc 100644 --- a/src/core_env.sig +++ b/src/core_env.sig @@ -33,6 +33,9 @@ signature CORE_ENV = sig val liftConInExp : int -> Core.exp -> Core.exp val subConInExp : (int * Core.con) -> Core.exp -> Core.exp + val liftExpInExp : int -> Core.exp -> Core.exp + val subExpInExp : (int * Core.exp) -> Core.exp -> Core.exp + type env val empty : env diff --git a/src/core_env.sml b/src/core_env.sml index b399f62f..0faf5aab 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -93,6 +93,35 @@ val subConInExp = bind = fn ((xn, rep), U.Exp.RelC _) => (xn+1, liftConInCon 0 rep) | (ctx, _) => ctx} +val liftExpInExp = + U.Exp.mapB {kind = fn k => k, + con = fn _ => fn c => c, + exp = fn bound => fn e => + case e of + ERel xn => + if xn < bound then + e + else + ERel (xn + 1) + | _ => e, + bind = fn (bound, U.Exp.RelE _) => bound + 1 + | (bound, _) => bound} + +val subExpInExp = + U.Exp.mapB {kind = fn k => k, + con = fn _ => fn c => c, + exp = fn (xn, rep) => fn e => + case e of + ERel xn' => + (case Int.compare (xn', xn) of + EQUAL => #1 rep + | GREATER=> ERel (xn' - 1) + | LESS => e) + | _ => e, + bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep) + | ((xn, rep), U.Exp.RelC _) => (xn, liftConInExp 0 rep) + | (ctx, _) => ctx} + (* Back to environments *) exception UnboundRel of int diff --git a/src/core_util.sig b/src/core_util.sig index 43750698..2ae75305 100644 --- a/src/core_util.sig +++ b/src/core_util.sig @@ -107,6 +107,11 @@ structure Exp : sig val exists : {kind : Core.kind' -> bool, con : Core.con' -> bool, exp : Core.exp' -> bool} -> Core.exp -> bool + + val foldMap : {kind : Core.kind' * 'state -> Core.kind' * 'state, + con : Core.con' * 'state -> Core.con' * 'state, + exp : Core.exp' * 'state -> Core.exp' * 'state} + -> 'state -> Core.exp -> Core.exp * 'state end structure Decl : sig diff --git a/src/core_util.sml b/src/core_util.sml index 49182c09..df8465ae 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -578,6 +578,13 @@ fun exists {kind, con, exp} k = S.Return _ => true | S.Continue _ => false +fun foldMap {kind, con, exp} s e = + case mapfold {kind = fn k => fn s => S.Continue (kind (k, s)), + con = fn c => fn s => S.Continue (con (c, s)), + exp = fn e => fn s => S.Continue (exp (e, s))} e s of + S.Continue v => v + | S.Return _ => raise Fail "CoreUtil.Exp.foldMap: Impossible" + end structure Decl = struct diff --git a/src/especialize.sig b/src/especialize.sig new file mode 100644 index 00000000..df83e81b --- /dev/null +++ b/src/especialize.sig @@ -0,0 +1,32 @@ +(* 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. + *) + +signature ESPECIALIZE = sig + + val specialize : Core.file -> Core.file + +end diff --git a/src/especialize.sml b/src/especialize.sml new file mode 100644 index 00000000..a316ffaa --- /dev/null +++ b/src/especialize.sml @@ -0,0 +1,176 @@ +(* 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. + *) + +structure ESpecialize :> ESPECIALIZE = struct + +open Core + +structure E = CoreEnv +structure U = CoreUtil + +structure ILK = struct +type ord_key = int list +val compare = Order.joinL Int.compare +end + +structure ILM = BinaryMapFn(ILK) +structure IM = IntBinaryMap + +type func = { + name : string, + args : int ILM.map, + body : exp, + typ : con, + tag : string +} + +type state = { + maxName : int, + funcs : func IM.map, + decls : (string * int * con * exp * string) list +} + +fun kind (k, st) = (k, st) +fun con (c, st) = (c, st) + +fun exp (e, st : state) = + let + fun getApp e = + case e of + ENamed f => SOME (f, [], []) + | EApp (e1, (ENamed x, _)) => + (case getApp (#1 e1) of + NONE => NONE + | SOME (f, xs, xs') => SOME (f, xs @ [x], xs')) + | EApp (e1, e2) => + (case getApp (#1 e1) of + NONE => NONE + | SOME (f, xs, xs') => SOME (f, xs, xs' @ [e2])) + | _ => NONE + in + case getApp e of + NONE => (e, st) + | SOME (_, [], _) => (e, st) + | SOME (f, xs, xs') => + case IM.find (#funcs st, f) of + NONE => (e, st) + | SOME {name, args, body, typ, tag} => + case ILM.find (args, xs) of + SOME f' => (#1 (foldl (fn (e, arg) => (EApp (e, arg), ErrorMsg.dummySpan)) + (ENamed f', ErrorMsg.dummySpan) xs'), + st) + | NONE => + let + fun subBody (body, typ, xs) = + case (#1 body, #1 typ, xs) of + (_, _, []) => SOME (body, typ) + | (EAbs (_, _, _, body'), TFun (_, typ'), x :: xs) => + subBody (E.subExpInExp (0, (ENamed x, ErrorMsg.dummySpan)) body', + typ', + xs) + | _ => NONE + in + case subBody (body, typ, xs) of + NONE => (e, st) + | SOME (body', typ') => + let + val f' = #maxName st + val funcs = IM.insert (#funcs st, f, {name = name, + args = ILM.insert (args, xs, f'), + body = body, + typ = typ, + tag = tag}) + val st = { + maxName = f' + 1, + funcs = funcs, + decls = #decls st + } + + val (body', st) = specExp st body' + val e' = foldl (fn (e, arg) => (EApp (e, arg), ErrorMsg.dummySpan)) + (ENamed f', ErrorMsg.dummySpan) xs' + in + (#1 e', + {maxName = #maxName st, + funcs = #funcs st, + decls = (name, f', typ', body', tag ^ "_espec") :: #decls st}) + end + end + end + +and specExp st = U.Exp.foldMap {kind = kind, con = con, exp = exp} st + +fun decl (d, st) = (d, st) + +val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl} + +fun specialize file = + let + fun doDecl (d, st) = + let + val (d', st) = specDecl st d + + val funcs = #funcs st + val funcs = + case #1 d of + DVal (x, n, c, e as (EAbs _, _), tag) => + IM.insert (funcs, n, {name = x, + args = ILM.empty, + body = e, + typ = c, + tag = tag}) + | DValRec vis => + foldl (fn ((x, n, c, e, tag), funcs) => + IM.insert (funcs, n, {name = x, + args = ILM.empty, + body = e, + typ = c, + tag = tag})) + funcs vis + | _ => funcs + + val ds = + case #decls st of + [] => [d'] + | vis => [(DValRec vis, ErrorMsg.dummySpan), d'] + in + (ds, {maxName = #maxName st, + funcs = funcs, + decls = []}) + end + + val (ds, _) = ListUtil.foldlMapConcat doDecl + {maxName = U.File.maxName file + 1, + funcs = IM.empty, + decls = []} + file + in + ds + end + + +end diff --git a/src/reduce.sml b/src/reduce.sml index 927c8ff1..8dc4527f 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -37,36 +37,8 @@ structure U = CoreUtil val liftConInCon = E.liftConInCon val subConInCon = E.subConInCon val liftConInExp = E.liftConInExp - -val liftExpInExp = - U.Exp.mapB {kind = fn k => k, - con = fn _ => fn c => c, - exp = fn bound => fn e => - case e of - ERel xn => - if xn < bound then - e - else - ERel (xn + 1) - | _ => e, - bind = fn (bound, U.Exp.RelE _) => bound + 1 - | (bound, _) => bound} - -val subExpInExp = - U.Exp.mapB {kind = fn k => k, - con = fn _ => fn c => c, - exp = fn (xn, rep) => fn e => - case e of - ERel xn' => - (case Int.compare (xn', xn) of - EQUAL => #1 rep - | GREATER=> ERel (xn' - 1) - | LESS => e) - | _ => e, - bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep) - | ((xn, rep), U.Exp.RelC _) => (xn, liftConInExp 0 rep) - | (ctx, _) => ctx} - +val liftExpInExp = E.liftExpInExp +val subExpInExp = E.subExpInExp val liftConInExp = E.liftConInExp val subConInExp = E.subConInExp diff --git a/src/sources b/src/sources index 3568279c..ebf71d9e 100644 --- a/src/sources +++ b/src/sources @@ -93,6 +93,9 @@ unpoly.sml specialize.sig specialize.sml +especialize.sig +especialize.sml + tag.sig tag.sml -- cgit v1.2.3 From 565f72b0d162990dcfcb91873102915bf8b9b3d7 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 30 Oct 2008 17:07:34 -0400 Subject: Remove _espec tag; add some tag fields --- lib/basis.urs | 6 +++--- src/especialize.sml | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/basis.urs b/lib/basis.urs index 0e6b9988..a344b3ce 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -370,9 +370,9 @@ 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] -val password : formTag string [] [] -val textarea : formTag string [] [] +val textbox : formTag string [] [Value = string, Size = int] +val password : formTag string [] [Value = string, Size = int] +val textarea : formTag string [] [Rows = int, Cols = int] val checkbox : formTag bool [] [Checked = bool] diff --git a/src/especialize.sml b/src/especialize.sml index a316ffaa..b2f0c7e6 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -117,7 +117,7 @@ fun exp (e, st : state) = (#1 e', {maxName = #maxName st, funcs = #funcs st, - decls = (name, f', typ', body', tag ^ "_espec") :: #decls st}) + decls = (name, f', typ', body', tag) :: #decls st}) end end end -- 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(-) 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 89f97891a33b5c0a8971d3508059a139a8815091 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 1 Nov 2008 10:47:10 -0400 Subject: Parsing 'let' --- src/elisp/urweb-defs.el | 23 +++++++++++---------- src/elisp/urweb-mode.el | 2 +- src/source.sml | 7 +++++++ src/source_print.sml | 55 +++++++++++++++++++++++++++++++++++-------------- src/urweb.grm | 12 +++++++++++ src/urweb.lex | 2 ++ tests/let.ur | 6 ++++++ tests/let.urp | 3 +++ 8 files changed, 82 insertions(+), 28 deletions(-) create mode 100644 tests/let.ur create mode 100644 tests/let.urp diff --git a/src/elisp/urweb-defs.el b/src/elisp/urweb-defs.el index 8b4ebe2e..fe4da2e4 100644 --- a/src/elisp/urweb-defs.el +++ b/src/elisp/urweb-defs.el @@ -91,7 +91,7 @@ notion of \"the end of an outline\".") (defconst urweb-begin-syms - '("struct" "sig") + '("let" "struct" "sig") "Symbols matching the `end' symbol.") (defconst urweb-begin-syms-re @@ -103,12 +103,12 @@ notion of \"the end of an outline\".") ;; "Symbols matching (loosely) the `end' symbol.") (defconst urweb-sexp-head-symbols-re - (urweb-syms-re "struct" "sig" "with" - "if" "then" "else" "case" "of" "fn" "fun" "val" "and" - "datatype" "type" "open" "include" - urweb-module-head-syms - "con" "fold" "where" "extern" "constraint" "constraints" - "table" "sequence" "class") + (urweb-syms-re "let" "struct" "sig" "in" "with" + "if" "then" "else" "case" "of" "fn" "fun" "val" "and" + "datatype" "type" "open" "include" + urweb-module-head-syms + "con" "fold" "where" "extern" "constraint" "constraints" + "table" "sequence" "class") "Symbols starting an sexp.") ;; (defconst urweb-not-arg-start-re @@ -133,11 +133,11 @@ notion of \"the end of an outline\".") ("if" "else" 0) (,urweb-=-starter-syms nil) (("case" "datatype" "if" "then" "else" - "open" "sig" "struct" "type" "val" + "let" "open" "sig" "struct" "type" "val" "con" "constraint" "table" "sequence" "class"))))) (defconst urweb-starters-indent-after - (urweb-syms-re "struct" "sig") + (urweb-syms-re "let" "in" "struct" "sig") "Indent after these.") (defconst urweb-delegate @@ -164,11 +164,12 @@ for all symbols and in all lines starting with the given symbol." (defconst urweb-open-paren (urweb-preproc-alist - `((,(list* urweb-begin-syms) ,urweb-begin-syms-re "\\"))) + `((,(list* "in" urweb-begin-syms) ,urweb-begin-syms-re "\\"))) "Symbols that should behave somewhat like opening parens.") (defconst urweb-close-paren - `(("end" ,urweb-begin-syms-re) + `(("in" "\\") + ("end" ,urweb-begin-syms-re) ("then" "\\") ("else" "\\" (urweb-bolp)) ("of" "\\") diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index 8c016e3d..1a578cf9 100644 --- a/src/elisp/urweb-mode.el +++ b/src/elisp/urweb-mode.el @@ -135,7 +135,7 @@ See doc for the variable `urweb-mode-info'." (urweb-syms-re "and" "case" "class" "con" "constraint" "constraints" "datatype" "else" "end" "extern" "fn" "fold" "fun" "functor" "if" "include" - "of" "open" + "of" "open" "let" "in" "rec" "sequence" "sig" "signature" "struct" "structure" "table" "then" "type" "val" "where" "with" diff --git a/src/source.sml b/src/source.sml index 386b1a83..7e204390 100644 --- a/src/source.sml +++ b/src/source.sml @@ -131,7 +131,14 @@ datatype exp' = | ECase of exp * (pat * exp) list + | ELet of edecl list * exp + +and edecl' = + EDVal of string * con option * exp + | EDValRec of (string * con option * exp) list + withtype exp = exp' located +and edecl = edecl' located datatype decl' = DCon of string * kind option * con diff --git a/src/source_print.sml b/src/source_print.sml index a25be2d4..9e6608df 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -285,8 +285,47 @@ fun p_exp' par (e, _) = | EWild => string "_" + | ELet (ds, e) => box [string "let", + newline, + box [p_list_sep newline p_edecl ds], + newline, + string "in", + newline, + box [p_exp e], + newline, + string "end"] + and p_exp e = p_exp' false e +and p_edecl (d, _) = + case d of + EDVal vi => box [string "val", + space, + p_vali vi] + | EDValRec vis => box [string "val", + space, + string "rec", + space, + p_list_sep (box [newline, string "and", space]) p_vali vis] + +and p_vali (x, co, e) = + case co of + NONE => box [string x, + space, + string "=", + space, + p_exp e] + | SOME t => box [string x, + space, + string ":", + space, + p_con t, + space, + string "=", + space, + p_exp e] + + fun p_datatype (x, xs, cons) = box [string "datatype", space, @@ -424,22 +463,6 @@ and p_sgn (sgn, _) = | SgnProj (m, ms, x) => p_list_sep (string ".") string (m :: ms @ [x]) -fun p_vali (x, co, e) = - case co of - NONE => box [string x, - space, - string "=", - space, - p_exp e] - | SOME t => box [string x, - space, - string ":", - space, - p_con t, - space, - string "=", - space, - p_exp e] fun p_decl ((d, _) : decl) = case d of diff --git a/src/urweb.grm b/src/urweb.grm index 143b6935..1555dc37 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -198,6 +198,7 @@ fun tagIn bt = | TYPE | NAME | ARROW | LARROW | DARROW | STAR | SEMI | FN | PLUSPLUS | MINUSMINUS | DOLLAR | TWIDDLE + | LET | IN | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE | CASE | IF | THEN | ELSE @@ -272,6 +273,8 @@ fun tagIn bt = | tag of string * exp | tagHead of string * exp | bind of string * con option * exp + | edecl of edecl + | edecls of edecl list | earg of exp * con -> exp * con | eargp of exp * con -> exp * con @@ -919,6 +922,15 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright)) | UNDER (EWild, s (UNDERleft, UNDERright)) + | LET edecls IN eexp END (ELet (edecls, eexp), s (LETleft, ENDright)) + +edecls : ([]) + | edecl edecls (edecl :: edecls) + +edecl : VAL vali ((EDVal vali, s (VALleft, valiright))) + | VAL REC valis ((EDValRec valis, s (VALleft, valisright))) + | FUN valis ((EDValRec valis, s (FUNleft, valisright))) + enterDml : (inDml := true) leaveDml : (inDml := false) diff --git a/src/urweb.lex b/src/urweb.lex index cc0f5b7c..d5393e7d 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -299,6 +299,8 @@ notags = [^<{\n]+; "signature" => (Tokens.SIGNATURE (pos yypos, pos yypos + size yytext)); "struct" => (Tokens.STRUCT (pos yypos, pos yypos + size yytext)); "sig" => (if yypos = 2 then initialSig () else (); Tokens.SIG (pos yypos, pos yypos + size yytext)); + "let" => (Tokens.LET (pos yypos, pos yypos + size yytext)); + "in" => (Tokens.IN (pos yypos, pos yypos + size yytext)); "end" => (Tokens.END (pos yypos, pos yypos + size yytext)); "functor" => (Tokens.FUNCTOR (pos yypos, pos yypos + size yytext)); "where" => (Tokens.WHERE (pos yypos, pos yypos + size yytext)); diff --git a/tests/let.ur b/tests/let.ur new file mode 100644 index 00000000..45d52ded --- /dev/null +++ b/tests/let.ur @@ -0,0 +1,6 @@ +fun main () : transaction page = + let + val x = 1 + in + return {[x]} + end diff --git a/tests/let.urp b/tests/let.urp new file mode 100644 index 00000000..4bb17d32 --- /dev/null +++ b/tests/let.urp @@ -0,0 +1,3 @@ +debug + +let -- cgit v1.2.3 From 3f497272d327fea2638006c751d812dbbc449c78 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 1 Nov 2008 11:17:29 -0400 Subject: Elaborating 'let' --- src/elab.sml | 7 +++++ src/elab_env.sig | 1 + src/elab_env.sml | 5 +++ src/elab_print.sml | 61 +++++++++++++++++++++++++++++++----- src/elab_util.sml | 42 +++++++++++++++++++++++++ src/elaborate.sml | 91 +++++++++++++++++++++++++++++++++++++++++++++++------- tests/let.ur | 4 ++- 7 files changed, 192 insertions(+), 19 deletions(-) diff --git a/src/elab.sml b/src/elab.sml index 4202d367..b5350c2a 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -117,7 +117,14 @@ datatype exp' = | EError | EUnif of exp option ref + | ELet of edecl list * exp + +and edecl' = + EDVal of string * con * exp + | EDValRec of (string * con * exp) list + withtype exp = exp' located + and edecl = edecl' located datatype sgn_item' = SgiConAbs of string * int * kind diff --git a/src/elab_env.sig b/src/elab_env.sig index 363cbe26..727ee259 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -85,6 +85,7 @@ signature ELAB_ENV = sig val lookupStr : env -> string -> (int * Elab.sgn) option + val edeclBinds : env -> Elab.edecl -> env val declBinds : env -> Elab.decl -> env val sgiBinds : env -> Elab.sgn_item -> env diff --git a/src/elab_env.sml b/src/elab_env.sml index edda9f38..f4f5d2cb 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -1075,6 +1075,11 @@ fun projectConstraints env {sgn, str} = | SgnError => SOME [] | _ => NONE +fun edeclBinds env (d, loc) = + case d of + EDVal (x, t, _) => pushERel env x t + | EDValRec vis => foldl (fn ((x, t, _), env) => pushERel env x t) env vis + fun declBinds env (d, loc) = case d of DCon (x, n, k, c) => pushCNamedAs env x n k (SOME c) diff --git a/src/elab_print.sml b/src/elab_print.sml index 8c0b41f7..3d7ce625 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -378,15 +378,52 @@ fun p_exp' par env (e, _) = | EUnif (ref (SOME e)) => p_exp env e | EUnif _ => string "_" + | ELet (ds, e) => + let + val (dsp, env) = ListUtil.foldlMap + (fn (d, env) => + (p_edecl env d, + E.edeclBinds env d)) + env ds + in + box [string "let", + newline, + box [p_list_sep newline (fn x => x) dsp], + newline, + string "in", + newline, + box [p_exp env e], + newline, + string "end"] + end + and p_exp env = p_exp' false env -fun p_named x n = - if !debug then - box [string x, - string "__", - string (Int.toString n)] - else - string x +and p_edecl env (dAll as (d, _)) = + case d of + EDVal vi => box [string "val", + space, + p_evali env vi] + | EDValRec vis => + let + val env = E.edeclBinds env dAll + in + box [string "val", + space, + string "rec", + space, + p_list_sep (box [newline, string "and", space]) (p_evali env) vis] + end + +and p_evali env (x, t, e) = box [string x, + space, + string ":", + space, + p_con env t, + space, + string "=", + space, + p_exp env e] fun p_datatype env (x, n, xs, cons) = let @@ -407,6 +444,14 @@ fun p_datatype env (x, n, xs, cons) = cons] end +fun p_named x n = + if !debug then + box [string x, + string "__", + string (Int.toString n)] + else + string x + fun p_sgn_item env (sgi, _) = case sgi of SgiConAbs (x, n, k) => box [string "con", @@ -556,6 +601,8 @@ fun p_vali env (x, n, t, e) = box [p_named x n, space, p_exp env e] + + fun p_decl env (dAll as (d, _) : decl) = case d of DCon (x, n, k, c) => box [string "con", diff --git a/src/elab_util.sml b/src/elab_util.sml index 247e2b3a..28fe8f22 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -352,6 +352,48 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = | EError => S.return2 eAll | EUnif (ref (SOME e)) => mfe ctx e | EUnif _ => S.return2 eAll + + | ELet (des, e) => + let + val (des, ctx) = foldl (fn (ed, (des, ctx)) => + (S.bind2 (des, + fn des' => + S.map2 (mfed ctx ed, + fn ed' => des' @ [ed'])), + case #1 ed of + EDVal (x, t, _) => bind (ctx, RelE (x, t)) + | EDValRec vis => + foldl (fn ((x, t, _), env) => bind (ctx, RelE (x, t))) ctx vis)) + (S.return2 [], ctx) des + in + S.bind2 (des, + fn des' => + S.map2 (mfe ctx e, + fn e' => + (ELet (des', e'), loc))) + end + + and mfed ctx (dAll as (d, loc)) = + case d of + EDVal vi => + S.map2 (mfvi ctx vi, + fn vi' => + (EDVal vi', loc)) + | EDValRec vis => + let + val ctx = foldl (fn ((x, t, _), env) => bind (ctx, RelE (x, t))) ctx vis + in + S.map2 (ListUtil.mapfold (mfvi ctx) vis, + fn vis' => + (EDValRec vis', loc)) + end + + and mfvi ctx (x, c, e) = + S.bind2 (mfc ctx c, + fn c' => + S.map2 (mfe ctx e, + fn e' => + (x, c', e'))) in mfe end diff --git a/src/elaborate.sml b/src/elaborate.sml index 4927e37d..38c03f6e 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1400,6 +1400,18 @@ fun normClassConstraint envs (c, loc) = end | _ => ((c, loc), []) + +val makeInstantiable = + let + fun kind k = k + fun con c = + case c of + L'.CDisjoint (L'.LeaveAlone, c1, c2, c) => L'.CDisjoint (L'.Instantiate, c1, c2, c) + | _ => c + in + U.Con.map {kind = kind, con = con} + end + fun elabExp (env, denv) (eAll as (e, loc)) = let (*val () = eprefaces "elabExp" [("eAll", SourcePrint.p_exp eAll)];*) @@ -1670,11 +1682,79 @@ fun elabExp (env, denv) (eAll as (e, loc)) = ((L'.ECase (e', pes', {disc = et, result = result}), loc), result, enD gs' @ gs) end + + | L.ELet (eds, e) => + let + val (eds, (env, gs1)) = ListUtil.foldlMap (elabEdecl denv) (env, []) eds + val (e, t, gs2) = elabExp (env, denv) e + in + ((L'.ELet (eds, e), loc), t, gs1 @ gs2) + end in (*prefaces "/elabExp" [("e", SourcePrint.p_exp eAll)];*) r end +and elabEdecl denv (dAll as (d, loc), (env, gs : constraint list)) = + let + val r = + case d of + L.EDVal (x, co, e) => + let + val (c', _, gs1) = case co of + NONE => (cunif (loc, ktype), ktype, []) + | SOME c => elabCon (env, denv) c + + val (e', et, gs2) = elabExp (env, denv) e + val gs3 = checkCon (env, denv) e' et c' + val (c', gs4) = normClassConstraint (env, denv) 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)) + end + | L.EDValRec vis => + let + fun allowable (e, _) = + case e of + L.EAbs _ => true + | L.ECAbs (_, _, _, e) => allowable e + | L.EDisjoint (_, _, e) => allowable e + | _ => false + + val (vis, gs) = ListUtil.foldlMap + (fn ((x, co, e), gs) => + let + val (c', _, gs1) = case co of + NONE => (cunif (loc, ktype), ktype, []) + | SOME c => elabCon (env, denv) c + in + ((x, c', e), enD gs1 @ gs) + end) gs vis + + val env = foldl (fn ((x, c', _), env) => E.pushERel env x c') env vis + + val (vis, gs) = ListUtil.foldlMap (fn ((x, c', e), gs) => + let + val (e', et, gs1) = elabExp (env, denv) e + + val gs2 = checkCon (env, denv) e' et c' + + val c' = makeInstantiable c' + in + if allowable e then + () + else + expError env (IllegalRec (x, e')); + ((x, c', e'), gs1 @ enD gs2 @ gs) + end) gs vis + in + ((L'.EDValRec vis, loc), (env, gs)) + end + in + r + end + val hnormSgn = E.hnormSgn fun tableOf () = (L'.CModProj (!basis_r, [], "sql_table"), ErrorMsg.dummySpan) @@ -2742,17 +2822,6 @@ fun wildifyStr env (str, sgn) = | _ => str) | _ => str -val makeInstantiable = - let - fun kind k = k - fun con c = - case c of - L'.CDisjoint (L'.LeaveAlone, c1, c2, c) => L'.CDisjoint (L'.Instantiate, c1, c2, c) - | _ => c - in - U.Con.map {kind = kind, con = con} - end - fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = let (*val () = preface ("elabDecl", SourcePrint.p_decl (d, loc))*) diff --git a/tests/let.ur b/tests/let.ur index 45d52ded..14dc936c 100644 --- a/tests/let.ur +++ b/tests/let.ur @@ -1,6 +1,8 @@ fun main () : transaction page = let val x = 1 + val y = "Hello" + val z = 3.45 in - return {[x]} + return {[x]}, {[y]}, {[z]} end -- cgit v1.2.3 From cfb8ffaf94885d8dc1b492a050830a9b4ffc3d04 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 1 Nov 2008 15:58:55 -0400 Subject: First Unnest tests working --- src/compiler.sig | 2 + src/compiler.sml | 9 +- src/elab_env.sig | 4 + src/elab_env.sml | 29 +++++ src/elab_print.sml | 4 +- src/elab_util.sig | 25 ++++ src/elab_util.sml | 107 ++++++++++++++- src/sources | 3 + src/termination.sml | 2 + src/unnest.sig | 34 +++++ src/unnest.sml | 369 ++++++++++++++++++++++++++++++++++++++++++++++++++++ tests/nest.ur | 41 ++++++ tests/nest.urp | 3 + 13 files changed, 627 insertions(+), 5 deletions(-) create mode 100644 src/unnest.sig create mode 100644 src/unnest.sml create mode 100644 tests/nest.ur create mode 100644 tests/nest.urp diff --git a/src/compiler.sig b/src/compiler.sig index e26ec13c..bc1974a1 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -58,6 +58,7 @@ signature COMPILER = sig val parse : (job, Source.file) phase val elaborate : (Source.file, Elab.file) phase + val unnest : (Elab.file, Elab.file) phase val termination : (Elab.file, Elab.file) phase val explify : (Elab.file, Expl.file) phase val corify : (Expl.file, Core.file) phase @@ -80,6 +81,7 @@ signature COMPILER = sig val toParseJob : (string, job) transform val toParse : (string, Source.file) transform val toElaborate : (string, Elab.file) transform + val toUnnest : (string, Elab.file) transform val toTermination : (string, Elab.file) transform val toExplify : (string, Expl.file) transform val toCorify : (string, Core.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 4f1bce11..e92f86c3 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -383,12 +383,19 @@ val elaborate = { val toElaborate = transform elaborate "elaborate" o toParse +val unnest = { + func = Unnest.unnest, + print = ElabPrint.p_file ElabEnv.empty +} + +val toUnnest = transform unnest "unnest" o toElaborate + val termination = { func = (fn file => (Termination.check file; file)), print = ElabPrint.p_file ElabEnv.empty } -val toTermination = transform termination "termination" o toElaborate +val toTermination = transform termination "termination" o toUnnest val explify = { func = Explify.explify, diff --git a/src/elab_env.sig b/src/elab_env.sig index 727ee259..90cf8153 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -30,6 +30,10 @@ signature ELAB_ENV = sig exception SynUnif val liftConInCon : int -> Elab.con -> Elab.con + val liftExpInExp : int -> Elab.exp -> Elab.exp + + val subExpInExp : (int * Elab.exp) -> Elab.exp -> Elab.exp + type env val empty : env diff --git a/src/elab_env.sml b/src/elab_env.sml index f4f5d2cb..2732de13 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -61,6 +61,20 @@ val liftConInCon = val lift = liftConInCon 0 +val liftConInExp = + U.Exp.mapB {kind = fn k => k, + con = fn bound => fn c => + case c of + CRel xn => + if xn < bound then + c + else + CRel (xn + 1) + | _ => c, + exp = fn _ => fn e => e, + bind = fn (bound, U.Exp.RelC _) => bound + 1 + | (bound, _) => bound} + val liftExpInExp = U.Exp.mapB {kind = fn k => k, con = fn _ => fn c => c, @@ -78,6 +92,21 @@ val liftExpInExp = val liftExp = liftExpInExp 0 +val subExpInExp = + U.Exp.mapB {kind = fn k => k, + con = fn _ => fn c => c, + exp = fn (xn, rep) => fn e => + case e of + ERel xn' => + (case Int.compare (xn', xn) of + EQUAL => #1 rep + | GREATER=> ERel (xn' - 1) + | LESS => e) + | _ => e, + bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep) + | ((xn, rep), U.Exp.RelC _) => (xn, liftConInExp 0 rep) + | (ctx, _) => ctx} + (* Back to environments *) datatype 'a var' = diff --git a/src/elab_print.sml b/src/elab_print.sml index 3d7ce625..b236954e 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -198,7 +198,7 @@ fun p_patCon env pc = string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) else string (#1 (E.lookupENamed env n))) - handle E.UnboundRel _ => string ("UNBOUND_NAMED" ^ Int.toString n)) + handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n)) | PConProj (m1, ms, x) => let val m1x = #1 (E.lookupStrNamed env m1) @@ -247,7 +247,7 @@ fun p_exp' par env (e, _) = string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) else string (#1 (E.lookupENamed env n))) - handle E.UnboundRel _ => string ("UNBOUND_NAMED" ^ Int.toString n)) + handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n)) | EModProj (m1, ms, x) => let val m1x = #1 (E.lookupStrNamed env m1) diff --git a/src/elab_util.sig b/src/elab_util.sig index f4edd972..f9988981 100644 --- a/src/elab_util.sig +++ b/src/elab_util.sig @@ -57,6 +57,11 @@ structure Con : sig -> Elab.con -> Elab.con val exists : {kind : Elab.kind' -> bool, con : Elab.con' -> bool} -> Elab.con -> bool + + val foldB : {kind : Elab.kind' * 'state -> 'state, + con : 'context * Elab.con' * 'state -> 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Elab.con -> 'state end structure Exp : sig @@ -83,6 +88,12 @@ structure Exp : sig val exists : {kind : Elab.kind' -> bool, con : Elab.con' -> bool, exp : Elab.exp' -> bool} -> Elab.exp -> bool + + val foldB : {kind : Elab.kind' * 'state -> 'state, + con : 'context * Elab.con' * 'state -> 'state, + exp : 'context * Elab.exp' * 'state -> 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Elab.exp -> 'state end structure Sgn : sig @@ -156,6 +167,20 @@ structure Decl : sig str : Elab.str' -> 'a option, decl : Elab.decl' -> 'a option} -> Elab.decl -> 'a option + + val foldMapB : {kind : Elab.kind' * 'state -> Elab.kind' * 'state, + con : 'context * Elab.con' * 'state -> Elab.con' * 'state, + exp : 'context * Elab.exp' * 'state -> Elab.exp' * 'state, + sgn_item : 'context * Elab.sgn_item' * 'state -> Elab.sgn_item' * 'state, + sgn : 'context * Elab.sgn' * 'state -> Elab.sgn' * 'state, + str : 'context * Elab.str' * 'state -> Elab.str' * 'state, + decl : 'context * Elab.decl' * 'state -> Elab.decl' * 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Elab.decl -> Elab.decl * 'state +end + +structure File : sig + val maxName : Elab.file -> int end end diff --git a/src/elab_util.sml b/src/elab_util.sml index 28fe8f22..2e190d1e 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -226,6 +226,13 @@ fun exists {kind, con} k = S.Return _ => true | S.Continue _ => false +fun foldB {kind, con, bind} ctx st c = + case mapfoldB {kind = fn k => fn st => S.Continue (k, kind (k, st)), + con = fn ctx => fn c => fn st => S.Continue (c, con (ctx, c, st)), + bind = bind} ctx c st of + S.Continue (_, st) => st + | S.Return _ => raise Fail "ElabUtil.Con.foldB: Impossible" + end structure Exp = struct @@ -340,8 +347,20 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = S.bind2 (mfe ctx e, fn e' => S.bind2 (ListUtil.mapfold (fn (p, e) => - S.map2 (mfe ctx e, - fn e' => (p, e'))) pes, + let + fun pb ((p, _), ctx) = + case p of + PWild => ctx + | PVar (x, t) => bind (ctx, RelE (x, t)) + | PPrim _ => ctx + | PCon (_, _, _, NONE) => ctx + | PCon (_, _, _, SOME p) => pb (p, ctx) + | PRecord xps => foldl (fn ((_, p, _), ctx) => + pb (p, ctx)) ctx xps + in + S.map2 (mfe (pb (p, ctx)) e, + fn e' => (p, e')) + end) pes, fn pes' => S.bind2 (mfc ctx disc, fn disc' => @@ -431,6 +450,14 @@ fun mapB {kind, con, exp, bind} ctx e = S.Continue (e, ()) => e | S.Return _ => raise Fail "ElabUtil.Exp.mapB: Impossible" +fun foldB {kind, con, exp, bind} ctx st e = + case mapfoldB {kind = fn k => fn st => S.Continue (k, kind (k, st)), + con = fn ctx => fn c => fn st => S.Continue (c, con (ctx, c, st)), + exp = fn ctx => fn e => fn st => S.Continue (e, exp (ctx, e, st)), + bind = bind} ctx e st of + S.Continue (_, st) => st + | S.Return _ => raise Fail "ElabUtil.Exp.foldB: Impossible" + end structure Sgn = struct @@ -888,6 +915,82 @@ fun search {kind, con, exp, sgn_item, sgn, str, decl} k = S.Return x => SOME x | S.Continue _ => NONE +fun foldMapB {kind, con, exp, sgn_item, sgn, str, decl, bind} ctx st d = + case mapfoldB {kind = fn x => fn st => S.Continue (kind (x, st)), + con = fn ctx => fn x => fn st => S.Continue (con (ctx, x, st)), + exp = fn ctx => fn x => fn st => S.Continue (exp (ctx, x, st)), + sgn_item = fn ctx => fn x => fn st => S.Continue (sgn_item (ctx, x, st)), + sgn = fn ctx => fn x => fn st => S.Continue (sgn (ctx, x, st)), + str = fn ctx => fn x => fn st => S.Continue (str (ctx, x, st)), + decl = fn ctx => fn x => fn st => S.Continue (decl (ctx, x, st)), + bind = bind} ctx d st of + S.Continue x => x + | S.Return _ => raise Fail "ElabUtil.Decl.foldMapB: Impossible" + +end + +structure File = struct + +fun maxName ds = foldl (fn (d, count) => Int.max (maxNameDecl d, count)) 0 ds + +and maxNameDecl (d, _) = + case d of + DCon (_, n, _, _) => n + | DDatatype (_, n, _, ns) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + n ns + | DDatatypeImp (_, n1, n2, _, _, _, ns) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + (Int.max (n1, n2)) ns + | DVal (_, n, _, _) => n + | DValRec vis => foldl (fn ((_, n, _, _), count) => Int.max (n, count)) 0 vis + | DStr (_, n, sgn, str) => Int.max (n, Int.max (maxNameSgn sgn, maxNameStr str)) + | DSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn) + | DFfiStr (_, n, sgn) => Int.max (n, maxNameSgn sgn) + | DConstraint _ => 0 + | DClass (_, n, _) => n + | DExport _ => 0 + | DTable (n, _, _, _) => n + | DSequence (n, _, _) => n + | DDatabase _ => 0 + +and maxNameStr (str, _) = + case str of + StrConst ds => maxName ds + | StrVar n => n + | StrProj (str, _) => maxNameStr str + | StrFun (_, n, dom, ran, str) => foldl Int.max n [maxNameSgn dom, maxNameSgn ran, maxNameStr str] + | StrApp (str1, str2) => Int.max (maxNameStr str1, maxNameStr str2) + | StrError => 0 + +and maxNameSgn (sgn, _) = + case sgn of + SgnConst sgis => foldl (fn (sgi, count) => Int.max (maxNameSgi sgi, count)) 0 sgis + | SgnVar n => n + | SgnFun (_, n, dom, ran) => Int.max (n, Int.max (maxNameSgn dom, maxNameSgn ran)) + | SgnWhere (sgn, _, _) => maxNameSgn sgn + | SgnProj (n, _, _) => n + | SgnError => 0 + +and maxNameSgi (sgi, _) = + case sgi of + SgiConAbs (_, n, _) => n + | SgiCon (_, n, _, _) => n + | SgiDatatype (_, n, _, ns) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + n ns + | SgiDatatypeImp (_, n1, n2, _, _, _, ns) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + (Int.max (n1, n2)) ns + | SgiVal (_, n, _) => n + | SgiStr (_, n, sgn) => Int.max (n, maxNameSgn sgn) + | SgiSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn) + | SgiConstraint _ => 0 + | SgiTable (n, _, _, _) => n + | SgiSequence (n, _, _) => n + | SgiClassAbs (_, n) => n + | SgiClass (_, n, _) => n + end end diff --git a/src/sources b/src/sources index ebf71d9e..984b5e23 100644 --- a/src/sources +++ b/src/sources @@ -50,6 +50,9 @@ elab_err.sml elaborate.sig elaborate.sml +unnest.sig +unnest.sml + termination.sig termination.sml diff --git a/src/termination.sml b/src/termination.sml index b0716eca..6ed4d92f 100644 --- a/src/termination.sml +++ b/src/termination.sml @@ -292,6 +292,8 @@ fun declOk' env (d, loc) = | EError => (Rabble, calls) | EUnif (ref (SOME e)) => exp parent (penv, calls) e | EUnif (ref NONE) => (Rabble, calls) + + | ELet (_, e) => exp parent (penv, calls) e end fun doVali (i, (_, f, _, e), calls) = diff --git a/src/unnest.sig b/src/unnest.sig new file mode 100644 index 00000000..6508a781 --- /dev/null +++ b/src/unnest.sig @@ -0,0 +1,34 @@ +(* 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. + *) + +(* Remove nested function definitions *) + +signature UNNEST = sig + + val unnest : Elab.file -> Elab.file + +end diff --git a/src/unnest.sml b/src/unnest.sml new file mode 100644 index 00000000..e5eddc42 --- /dev/null +++ b/src/unnest.sml @@ -0,0 +1,369 @@ +(* 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. + *) + +(* Remove nested function definitions *) + +structure Unnest :> UNNEST = struct + +open Elab + +structure E = ElabEnv +structure U = ElabUtil + +structure IS = IntBinarySet + +val fvsCon = U.Con.foldB {kind = fn (_, st) => st, + con = fn (cb, c, cvs) => + case c of + CRel n => + if n >= cb then + IS.add (cvs, n - cb) + else + cvs + | _ => cvs, + bind = fn (cb, b) => + case b of + U.Con.Rel _ => cb + 1 + | _ => cb} + 0 IS.empty + +fun fvsExp nr = U.Exp.foldB {kind = fn (_, st) => st, + con = fn ((cb, eb), c, st as (cvs, evs)) => + case c of + CRel n => + if n >= cb then + (IS.add (cvs, n - cb), evs) + else + st + | _ => st, + exp = fn ((cb, eb), e, st as (cvs, evs)) => + case e of + ERel n => + if n >= eb then + (cvs, IS.add (evs, n - eb)) + else + st + | _ => st, + bind = fn (ctx as (cb, eb), b) => + case b of + U.Exp.RelC _ => (cb + 1, eb) + | U.Exp.RelE _ => (cb, eb + 1) + | _ => ctx} + (0, nr) (IS.empty, IS.empty) + +fun positionOf (x : int) ls = + let + fun po n ls = + case ls of + [] => raise Fail "Unnest.positionOf" + | x' :: ls' => + if x' = x then + n + else + po (n + 1) ls' + in + po 0 ls + handle Fail _ => raise Fail ("Unnset.positionOf(" + ^ Int.toString x + ^ ", " + ^ String.concatWith ";" (map Int.toString ls) + ^ ")") + end + +fun squishCon cfv = + U.Con.mapB {kind = fn k => k, + con = fn cb => fn c => + case c of + CRel n => + if n >= cb then + CRel (positionOf (n - cb) cfv + cb) + else + c + | _ => c, + bind = fn (cb, b) => + case b of + U.Con.Rel _ => cb + 1 + | _ => cb} + 0 + +fun squishExp (nr, cfv, efv) = + U.Exp.mapB {kind = fn k => k, + con = fn (cb, eb) => fn c => + case c of + CRel n => + if n >= cb then + CRel (positionOf (n - cb) cfv + cb) + else + c + | _ => c, + exp = fn (cb, eb) => fn e => + case e of + ERel n => + if n >= eb then + ERel (positionOf (n - eb) efv + eb) + else + e + | _ => e, + bind = fn (ctx as (cb, eb), b) => + case b of + U.Exp.RelC _ => (cb + 1, eb) + | U.Exp.RelE _ => (cb, eb + 1) + | _ => ctx} + (0, nr) + +type state = { + maxName : int, + decls : decl list +} + +fun kind (k, st) = (k, st) + +fun exp ((ks, ts), e, st : state) = + case e of + ELet (eds, e) => + let + val doSubst = foldl (fn (p, e) => E.subExpInExp p e) + + val (eds, (maxName, ds, subs)) = + ListUtil.foldlMapConcat + (fn (ed, (maxName, ds, subs)) => + case #1 ed of + EDVal _ => ([ed], (maxName, ds, map (fn (n, e) => (n + 1, E.liftExpInExp 0 e)) subs)) + | EDValRec vis => + let + val loc = #2 ed + + val nr = length vis + val (cfv, efv) = foldl (fn ((_, t, e), (cfv, efv)) => + let + val (cfv', efv') = fvsExp nr e + (*val () = Print.prefaces "fvsExp" + [("e", ElabPrint.p_exp E.empty e), + ("cfv", Print.PD.string + (Int.toString (IS.numItems cfv'))), + ("efv", Print.PD.string + (Int.toString (IS.numItems efv')))]*) + val cfv'' = fvsCon t + in + (IS.union (cfv, IS.union (cfv', cfv'')), + IS.union (efv, efv')) + end) + (IS.empty, IS.empty) vis + + (*val () = print ("A: " ^ Int.toString (length ts) ^ ", " ^ Int.toString (length ks) ^ "\n")*) + val cfv = IS.foldl (fn (x, cfv) => + let + (*val () = print (Int.toString x ^ "\n")*) + val (_, t) = List.nth (ts, x) + in + IS.union (cfv, fvsCon t) + end) + cfv efv + (*val () = print "B\n"*) + + val (vis, maxName) = + ListUtil.foldlMap (fn ((x, t, e), maxName) => + ((x, maxName, t, e), + maxName + 1)) + maxName vis + + fun apply e = + let + val e = IS.foldl (fn (x, e) => + (ECApp (e, (CRel x, loc)), loc)) + e cfv + in + IS.foldl (fn (x, e) => + (EApp (e, (ERel x, loc)), loc)) + e efv + end + + val subs = map (fn (n, e) => (n + nr, E.liftExpInExp nr e)) subs + + val subs' = ListUtil.mapi (fn (i, (_, n, _, _)) => + let + val e = apply (ENamed n, loc) + in + (0, E.liftExpInExp (nr - i - 1) e) + end) + 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 () = Print.prefaces "squishCon" + [("t", ElabPrint.p_con E.empty t)]*) + val t = squishCon cfv t + (*val () = Print.prefaces "squishExp" + [("e", ElabPrint.p_exp E.empty e)]*) + val e = squishExp (nr, cfv, efv) e + + val (e, t) = foldr (fn (ex, (e, t)) => + let + val (name, t') = List.nth (ts, ex) + in + ((EAbs (name, + t', + t, + e), loc), + (TFun (t', + t), loc)) + end) + (e, t) efv + + val (e, t) = foldr (fn (cx, (e, t)) => + let + val (name, k) = List.nth (ks, cx) + in + ((ECAbs (Explicit, + name, + k, + e), loc), + (TCFun (Explicit, + name, + k, + t), loc)) + end) + (e, t) cfv + in + (x, n, t, e) + end) + vis + + val d = (DValRec vis, #2 ed) + in + ([], (maxName, d :: ds, subs)) + end) + (#maxName st, #decls st, []) eds + in + (ELet (eds, doSubst e subs), + {maxName = maxName, + decls = ds}) + end + + | _ => (e, st) + +fun default (ctx, d, st) = (d, st) + +fun bind ((ks, ts), b) = + case b of + U.Decl.RelC p => (p :: ks, map (fn (name, t) => (name, E.liftConInCon 0 t)) ts) + | U.Decl.RelE p => (ks, p :: ts) + | _ => (ks, ts) + +val unnestDecl = U.Decl.foldMapB {kind = kind, + con = default, + exp = exp, + sgn_item = default, + sgn = default, + str = default, + decl = default, + bind = bind} + ([], []) + +fun unnest file = + let + fun doDecl (all as (d, loc), st : state) = + let + fun default () = ([all], st) + fun explore () = + let + val (d, st) = unnestDecl st all + in + (rev (d :: #decls st), + {maxName = #maxName st, + decls = []}) + end + in + case d of + DCon _ => default () + | DDatatype _ => default () + | DDatatypeImp _ => default () + | DVal _ => explore () + | DValRec _ => explore () + | DSgn _ => default () + | DStr (x, n, sgn, str) => + let + val (str, st) = doStr (str, st) + in + ([(DStr (x, n, sgn, str), loc)], st) + end + | DFfiStr _ => default () + | DConstraint _ => default () + | DExport _ => default () + | DTable _ => default () + | DSequence _ => default () + | DClass _ => default () + | DDatabase _ => default () + end + + and doStr (all as (str, loc), st) = + let + fun default () = (all, st) + in + case str of + StrConst ds => + let + val (ds, st) = ListUtil.foldlMapConcat doDecl st ds + in + ((StrConst ds, loc), st) + end + | StrVar _ => default () + | StrProj _ => default () + | StrFun (x, n, dom, ran, str) => + let + val (str, st) = doStr (str, st) + in + ((StrFun (x, n, dom, ran, str), loc), st) + end + | StrApp _ => default () + | StrError => raise Fail "Unnest: StrError" + end + + val (ds, _) = ListUtil.foldlMapConcat doDecl + {maxName = U.File.maxName file + 1, + decls = []} file + in + ds + end + +end diff --git a/tests/nest.ur b/tests/nest.ur new file mode 100644 index 00000000..c136b1e6 --- /dev/null +++ b/tests/nest.ur @@ -0,0 +1,41 @@ +fun add x = + let + fun add' y = x + y + in + add' 1 + add' 2 + end + +fun f (x : int) = + let + fun page () = return + {[x]} + + in + page + end + +fun f (x : int) = + let + fun page1 () = return + {[x]} + + + and page2 () = + case Some True of + Some r => return {[r]} + | _ => return Error + in + page1 + end + +datatype list t = Nil | Cons of t * list t + +fun length (t ::: Type) (ls : list t) = + let + fun length' ls acc = + case ls of + Nil => acc + | Cons (_, ls') => length' ls' (acc + 1) + in + length' ls 0 + end diff --git a/tests/nest.urp b/tests/nest.urp new file mode 100644 index 00000000..7f8a473a --- /dev/null +++ b/tests/nest.urp @@ -0,0 +1,3 @@ +debug + +nest -- cgit v1.2.3 From 1145290f6ac5b13fe94772c692caa3cdb55bbf5f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 1 Nov 2008 16:08:39 -0400 Subject: Explify 'let' --- src/expl.sml | 2 ++ src/expl_print.sml | 46 +++++++++++++++++++++++++++++++++------------- src/expl_util.sml | 9 +++++++++ src/explify.sml | 7 +++++++ 4 files changed, 51 insertions(+), 13 deletions(-) diff --git a/src/expl.sml b/src/expl.sml index 2e96db54..8f531516 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -98,6 +98,8 @@ datatype exp' = | EWrite of exp + | ELet of string * con * exp * exp + withtype exp = exp' located datatype sgn_item' = diff --git a/src/expl_print.sml b/src/expl_print.sml index d19edeae..b19a6eff 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -83,10 +83,11 @@ fun p_con' par env (c, _) = p_con' true env c] | CRel n => - if !debug then - string (#1 (E.lookupCRel env n) ^ "_" ^ Int.toString n) - else - string (#1 (E.lookupCRel env n)) + ((if !debug then + string (#1 (E.lookupCRel env n) ^ "_" ^ Int.toString n) + else + string (#1 (E.lookupCRel env n))) + handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n)) | CNamed n => ((if !debug then string (#1 (E.lookupCNamed env n) ^ "__" ^ Int.toString n) @@ -172,7 +173,7 @@ fun p_patCon env pc = string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) else string (#1 (E.lookupENamed env n))) - handle E.UnboundRel _ => string ("UNBOUND_NAMED" ^ Int.toString n)) + handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n)) | PConProj (m1, ms, x) => let val m1x = #1 (E.lookupStrNamed env m1) @@ -211,15 +212,17 @@ fun p_exp' par env (e, loc) = case e of EPrim p => Prim.p_t p | ERel n => - if !debug then - string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n) - else - string (#1 (E.lookupERel env n)) + ((if !debug then + string (#1 (E.lookupERel env n) ^ "_" ^ Int.toString n) + else + string (#1 (E.lookupERel env n))) + handle E.UnboundRel _ => string ("UNBOUND_REL" ^ Int.toString n)) | ENamed n => - if !debug then - string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) - else - string (#1 (E.lookupENamed env n)) + ((if !debug then + string (#1 (E.lookupENamed env n) ^ "__" ^ Int.toString n) + else + string (#1 (E.lookupENamed env n))) + handle E.UnboundNamed _ => string ("UNBOUND_NAMED" ^ Int.toString n)) | EModProj (m1, ms, x) => let val (m1x, sgn) = E.lookupStrNamed env m1 @@ -362,6 +365,23 @@ fun p_exp' par env (e, loc) = space, p_exp env e]) pes]) + | 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/expl_util.sml b/src/expl_util.sml index bda602d3..e12186b0 100644 --- a/src/expl_util.sml +++ b/src/expl_util.sml @@ -325,6 +325,15 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = S.map2 (mfc ctx result, fn result' => (ECase (e', pes', {disc = disc', result = result'}), 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)))) in mfe end diff --git a/src/explify.sml b/src/explify.sml index 1bca49c3..e19bb200 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -116,6 +116,13 @@ fun explifyExp (e, loc) = | L.EUnif (ref (SOME e)) => explifyExp e | L.EUnif _ => raise Fail ("explifyExp: Undetermined EUnif at " ^ EM.spanToString loc) + | L.ELet (des, e) => + foldr (fn ((de, loc), e) => + case de of + L.EDValRec _ => raise Fail "explifyExp: Local 'val rec' remains" + | L.EDVal (x, t, e') => (L'.ELet (x, explifyCon t, explifyExp e', e), loc)) + (explifyExp e) des + fun explifySgi (sgi, loc) = case sgi of L.SgiConAbs (x, n, k) => SOME (L'.SgiConAbs (x, n, explifyKind k), loc) -- 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(-) 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 36a9df5f71b954949b92520c6e472548aa5ebfb1 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 1 Nov 2008 16:50:28 -0400 Subject: Remove empty writes --- src/mono_opt.sml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 8d11fe1a..3cf2bcd4 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -311,6 +311,9 @@ fun exp e = | EWrite (ELet (x, t, e1, e2), loc) => optExp (ELet (x, t, e1, (EWrite e2, loc)), loc) + | EWrite (EPrim (Prim.String ""), loc) => + ERecord [] + | _ => e and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) -- 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(+) 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 047a2f193646e08db526768dca8376b7270eecb5 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 1 Nov 2008 21:19:43 -0400 Subject: Almost have that nested save function compiling --- src/cjrize.sml | 19 ++++--- src/core_util.sml | 2 +- src/elab_util.sml | 21 +++++--- src/especialize.sml | 149 +++++++++++++++++++++++++++++++++++++--------------- src/expl_print.sml | 1 + src/expl_util.sml | 2 +- src/mono_opt.sml | 15 +++++- src/mono_reduce.sig | 4 +- src/shake.sml | 28 +++++++--- src/sources | 6 +-- src/termination.sml | 10 +++- src/unnest.sml | 35 +++++++----- tests/blog.ur | 16 ++++++ tests/blog.urp | 4 ++ tests/blog.urs | 1 + tests/nest.ur | 22 +++++++- tests/nest2.ur | 15 ++++++ tests/nest2.urp | 3 ++ 18 files changed, 268 insertions(+), 85 deletions(-) create mode 100644 tests/blog.ur create mode 100644 tests/blog.urp create mode 100644 tests/blog.urs create mode 100644 tests/nest2.ur create mode 100644 tests/nest2.urp diff --git a/src/cjrize.sml b/src/cjrize.sml index 05ceb0f9..db2bd48f 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -39,6 +39,7 @@ structure Sm :> sig val find : t * (string * L.typ) list * (string * L'.typ) list -> t * int val declares : t -> (int * (string * L'.typ) list) list + val clearDeclares : t -> t end = struct structure FM = BinaryMapFn(struct @@ -61,6 +62,8 @@ fun find ((n, m, ds), xts, xts') = fun declares (_, _, ds) = ds +fun clearDeclares (n, m, _) = (n, m, []) + end fun cifyTyp x = @@ -520,23 +523,25 @@ fun cjrize ds = val (dsF, ds, ps, sm) = foldl (fn (d, (dsF, ds, ps, sm)) => let val (dop, pop, sm) = cifyDecl (d, sm) + val (dsF, ds) = case dop of NONE => (dsF, ds) - | SOME (d as (L'.DDatatype (dk, x, n, _), loc)) => - ((L'.DDatatypeForward (dk, x, n), loc) :: dsF, - d :: ds) + | SOME (d as (L'.DDatatype _, loc)) => + (d :: dsF, ds) | SOME d => (dsF, d :: ds) + + val dsF = map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm) + @ dsF + val ps = case pop of NONE => ps | SOME p => p :: ps in - (dsF, ds, ps, sm) + (dsF, ds, ps, Sm.clearDeclares sm) end) ([], [], [], Sm.empty) ds in - (List.revAppend (dsF, - List.revAppend (map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm), - rev ds)), + (List.revAppend (dsF, rev ds), ps) end diff --git a/src/core_util.sml b/src/core_util.sml index 2a690736..2450562f 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -492,7 +492,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = fn t' => S.bind2 (mfe ctx e1, fn e1' => - S.map2 (mfe ctx e2, + S.map2 (mfe (bind (ctx, RelE (x, t'))) e2, fn e2' => (ELet (x, t', e1', e2'), loc)))) diff --git a/src/elab_util.sml b/src/elab_util.sml index 2e190d1e..57a94486 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -375,14 +375,19 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = | ELet (des, e) => let val (des, ctx) = foldl (fn (ed, (des, ctx)) => - (S.bind2 (des, - fn des' => - S.map2 (mfed ctx ed, + let + val ctx' = + case #1 ed of + EDVal (x, t, _) => bind (ctx, RelE (x, t)) + | EDValRec vis => + foldl (fn ((x, t, _), ctx) => bind (ctx, RelE (x, t))) ctx vis + in + (S.bind2 (des, + fn des' => + S.map2 (mfed ctx ed, fn ed' => des' @ [ed'])), - case #1 ed of - EDVal (x, t, _) => bind (ctx, RelE (x, t)) - | EDValRec vis => - foldl (fn ((x, t, _), env) => bind (ctx, RelE (x, t))) ctx vis)) + ctx') + end) (S.return2 [], ctx) des in S.bind2 (des, @@ -400,7 +405,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = (EDVal vi', loc)) | EDValRec vis => let - val ctx = foldl (fn ((x, t, _), env) => bind (ctx, RelE (x, t))) ctx vis + val ctx = foldl (fn ((x, t, _), ctx) => bind (ctx, RelE (x, t))) ctx vis in S.map2 (ListUtil.mapfold (mfvi ctx) vis, fn vis' => diff --git a/src/especialize.sml b/src/especialize.sml index b2f0c7e6..d5e93680 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -32,17 +32,43 @@ open Core structure E = CoreEnv structure U = CoreUtil -structure ILK = struct -type ord_key = int list -val compare = Order.joinL Int.compare +datatype skey = + Named of int + | App of skey * skey + +structure K = struct +type ord_key = skey list +fun compare' (k1, k2) = + case (k1, k2) of + (Named n1, Named n2) => Int.compare (n1, n2) + | (Named _, _) => LESS + | (_, Named _) => GREATER + + | (App (x1, y1), App (x2, y2)) => Order.join (compare' (x1, x2), fn () => compare' (y1, y2)) + +val compare = Order.joinL compare' end -structure ILM = BinaryMapFn(ILK) +structure KM = BinaryMapFn(K) structure IM = IntBinaryMap +fun skeyIn (e, _) = + case e of + ENamed n => SOME (Named n) + | EApp (e1, e2) => + (case (skeyIn e1, skeyIn e2) of + (SOME k1, SOME k2) => SOME (App (k1, k2)) + | _ => NONE) + | _ => NONE + +fun skeyOut (k, loc) = + case k of + Named n => (ENamed n, loc) + | App (k1, k2) => (EApp (skeyOut (k1, loc), skeyOut (k2, loc)), loc) + type func = { name : string, - args : int ILM.map, + args : int KM.map, body : exp, typ : con, tag : string @@ -62,14 +88,21 @@ fun exp (e, st : state) = fun getApp e = case e of ENamed f => SOME (f, [], []) - | EApp (e1, (ENamed x, _)) => - (case getApp (#1 e1) of - NONE => NONE - | SOME (f, xs, xs') => SOME (f, xs @ [x], xs')) | EApp (e1, e2) => (case getApp (#1 e1) of NONE => NONE - | SOME (f, xs, xs') => SOME (f, xs, xs' @ [e2])) + | SOME (f, xs, xs') => + let + val k = + if List.null xs' then + skeyIn e2 + else + NONE + in + case k of + NONE => SOME (f, xs, xs' @ [e2]) + | SOME k => SOME (f, xs @ [k], xs') + end) | _ => NONE in case getApp e of @@ -77,21 +110,30 @@ fun exp (e, st : state) = | SOME (_, [], _) => (e, st) | SOME (f, xs, xs') => case IM.find (#funcs st, f) of - NONE => (e, st) + NONE => ((*print "SHOT DOWN!\n";*) (e, st)) | SOME {name, args, body, typ, tag} => - case ILM.find (args, xs) of - SOME f' => (#1 (foldl (fn (e, arg) => (EApp (e, arg), ErrorMsg.dummySpan)) - (ENamed f', ErrorMsg.dummySpan) xs'), - st) + case KM.find (args, xs) of + SOME f' => ((*Print.prefaces "Pre-existing" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))];*) + (#1 (foldl (fn (e, arg) => (EApp (e, arg), ErrorMsg.dummySpan)) + (ENamed f', ErrorMsg.dummySpan) xs'), + st)) | NONE => let + (*val () = Print.prefaces "New" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))]*) + fun subBody (body, typ, xs) = case (#1 body, #1 typ, xs) of (_, _, []) => SOME (body, typ) | (EAbs (_, _, _, body'), TFun (_, typ'), x :: xs) => - subBody (E.subExpInExp (0, (ENamed x, ErrorMsg.dummySpan)) body', - typ', - xs) + let + val body'' = E.subExpInExp (0, skeyOut (x, #2 body)) body' + in + (*Print.prefaces "espec" [("body'", CorePrint.p_exp CoreEnv.empty body'), + ("body''", CorePrint.p_exp CoreEnv.empty body'')];*) + subBody (body'', + typ', + xs) + end | _ => NONE in case subBody (body, typ, xs) of @@ -99,8 +141,9 @@ fun exp (e, st : state) = | SOME (body', typ') => let val f' = #maxName st + (*val () = print ("f' = " ^ Int.toString f' ^ "\n")*) val funcs = IM.insert (#funcs st, f, {name = name, - args = ILM.insert (args, xs, f'), + args = KM.insert (args, xs, f'), body = body, typ = typ, tag = tag}) @@ -128,10 +171,27 @@ fun decl (d, st) = (d, st) val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl} -fun specialize file = +fun specialize' file = let - fun doDecl (d, st) = + fun doDecl (d, (st : state, changed)) = let + val funcs = #funcs st + val funcs = + case #1 d of + DValRec vis => + foldl (fn ((x, n, c, e, tag), funcs) => + IM.insert (funcs, n, {name = x, + args = KM.empty, + body = e, + typ = c, + tag = tag})) + funcs vis + | _ => funcs + + val st = {maxName = #maxName st, + funcs = funcs, + decls = []} + val (d', st) = specDecl st d val funcs = #funcs st @@ -139,37 +199,42 @@ fun specialize file = case #1 d of DVal (x, n, c, e as (EAbs _, _), tag) => IM.insert (funcs, n, {name = x, - args = ILM.empty, + args = KM.empty, body = e, typ = c, tag = tag}) - | DValRec vis => - foldl (fn ((x, n, c, e, tag), funcs) => - IM.insert (funcs, n, {name = x, - args = ILM.empty, - body = e, - typ = c, - tag = tag})) - funcs vis | _ => funcs - val ds = + val (changed, ds) = case #decls st of - [] => [d'] - | vis => [(DValRec vis, ErrorMsg.dummySpan), d'] + [] => (changed, [d']) + | vis => + (true, case d' of + (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)] + | _ => [(DValRec vis, ErrorMsg.dummySpan), d']) in - (ds, {maxName = #maxName st, - funcs = funcs, - decls = []}) + (ds, ({maxName = #maxName st, + funcs = funcs, + decls = []}, changed)) end - val (ds, _) = ListUtil.foldlMapConcat doDecl - {maxName = U.File.maxName file + 1, - funcs = IM.empty, - decls = []} - file + val (ds, (_, changed)) = ListUtil.foldlMapConcat doDecl + ({maxName = U.File.maxName file + 1, + funcs = IM.empty, + decls = []}, false) + file + in + (changed, ds) + end + +fun specialize file = + let + val (changed, file) = specialize' file in - ds + if changed then + specialize file + else + file end diff --git a/src/expl_print.sml b/src/expl_print.sml index b19a6eff..aecc3a84 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -370,6 +370,7 @@ fun p_exp' par env (e, loc) = string x, space, string ":", + space, p_con env t, space, string "=", diff --git a/src/expl_util.sml b/src/expl_util.sml index e12186b0..337ea8d6 100644 --- a/src/expl_util.sml +++ b/src/expl_util.sml @@ -331,7 +331,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = fn t' => S.bind2 (mfe ctx e1, fn e1' => - S.map2 (mfe ctx e2, + S.map2 (mfe (bind (ctx, RelE (x, t))) e2, fn e2' => (ELet (x, t', e1', e2'), loc)))) in diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 3cf2bcd4..b22f053b 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -89,7 +89,7 @@ fun sqlifyFloat n = attrifyFloat n ^ "::float8" fun sqlifyString s = "E'" ^ String.translate (fn #"'" => "\\'" | ch => str ch) (String.toString s) ^ "'::text" - + fun exp e = case e of EPrim (Prim.String s) => @@ -287,6 +287,19 @@ fun exp e = {disc = disc, result = (TRecord [], loc)}), loc) + | EApp ((ECase (discE, pes, {disc, ...}), loc), arg as (ERecord [], _)) => + let + fun doBody e = + case #1 e of + EAbs (_, _, _, body) => MonoReduce.subExpInExp (0, arg) body + | _ => (EApp (e, arg), loc) + in + optExp (ECase (discE, + map (fn (p, e) => (p, doBody e)) pes, + {disc = disc, + result = (TRecord [], loc)}), loc) + end + | EWrite (EQuery {exps, tables, state, query, initial = (EPrim (Prim.String ""), _), body = (EStrcat ((EPrim (Prim.String s), _), diff --git a/src/mono_reduce.sig b/src/mono_reduce.sig index 3769a0f5..2495c7f9 100644 --- a/src/mono_reduce.sig +++ b/src/mono_reduce.sig @@ -30,5 +30,7 @@ signature MONO_REDUCE = sig val reduce : Mono.file -> Mono.file - + + val subExpInExp : int * Mono.exp -> Mono.exp -> Mono.exp + end diff --git a/src/shake.sml b/src/shake.sml index 38d72cc5..4ebd1b0b 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -55,14 +55,19 @@ fun shake file = val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef) | ((DDatatype (_, n, _, xncs), _), (cdef, edef)) => (IM.insert (cdef, n, List.mapPartial #3 xncs), edef) - | ((DVal (_, n, t, e, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, (t, e))) + | ((DVal (_, n, t, e, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], t, e))) | ((DValRec vis, _), (cdef, edef)) => - (cdef, foldl (fn ((_, n, t, e, _), edef) => IM.insert (edef, n, (t, e))) edef vis) + let + val all_ns = map (fn (_, n, _, _, _) => n) vis + in + (cdef, foldl (fn ((_, n, t, e, _), edef) => + IM.insert (edef, n, (all_ns, t, e))) edef vis) + end | ((DExport _, _), acc) => acc | ((DTable (_, n, c, _), _), (cdef, edef)) => - (cdef, IM.insert (edef, n, (c, dummye))) + (cdef, IM.insert (edef, n, ([], c, dummye))) | ((DSequence (_, n, _), _), (cdef, edef)) => - (cdef, IM.insert (edef, n, (dummyt, dummye))) + (cdef, IM.insert (edef, n, ([], dummyt, dummye))) | ((DDatabase _, _), acc) => acc) (IM.empty, IM.empty) file @@ -96,9 +101,15 @@ fun shake file = val s' = {exp = IS.add (#exp s, n), con = #con s} in + (*print ("Need " ^ Int.toString n ^ "\n");*) case IM.find (edef, n) of NONE => s' - | SOME (t, e) => shakeExp (shakeCon s' t) e + | SOME (ns, t, e) => + let + val s' = shakeExp (shakeCon s' t) e + in + foldl (fn (n, s') => exp (ENamed n, s')) s' ns + end end | _ => s @@ -109,7 +120,12 @@ fun shake file = val s = foldl (fn (n, s) => case IM.find (edef, n) of NONE => raise Fail "Shake: Couldn't find 'val'" - | SOME (t, e) => shakeExp (shakeCon s t) e) s page_es + | SOME (ns, t, e) => + let + val s = shakeExp (shakeCon s t) e + in + foldl (fn (n, s) => exp (ENamed n, s)) s ns + end) s page_es val s = foldl (fn (c, s) => shakeCon s c) s table_cs in diff --git a/src/sources b/src/sources index 984b5e23..504013d8 100644 --- a/src/sources +++ b/src/sources @@ -116,15 +116,15 @@ mono_print.sml monoize.sig monoize.sml +mono_reduce.sig +mono_reduce.sml + mono_opt.sig mono_opt.sml untangle.sig untangle.sml -mono_reduce.sig -mono_reduce.sml - mono_shake.sig mono_shake.sml diff --git a/src/termination.sml b/src/termination.sml index 6ed4d92f..2db5bb11 100644 --- a/src/termination.sml +++ b/src/termination.sml @@ -293,7 +293,15 @@ fun declOk' env (d, loc) = | EUnif (ref (SOME e)) => exp parent (penv, calls) e | EUnif (ref NONE) => (Rabble, calls) - | ELet (_, e) => exp parent (penv, calls) e + | ELet (eds, e) => + let + fun extPenv ((ed, _), penv) = + case ed of + EDVal _ => Rabble :: penv + | EDValRec vis => foldl (fn (_, penv) => Rabble :: penv) penv vis + in + exp parent (foldl extPenv penv eds, calls) e + end end fun doVali (i, (_, f, _, e), calls) = diff --git a/src/unnest.sml b/src/unnest.sml index b305b467..f226a678 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -124,7 +124,7 @@ fun squishExp (nr, cfv, efv) = case e of ERel n => if n >= eb then - ERel (positionOf (n - eb) efv + eb) + ERel (positionOf (n - eb) efv + eb) else e | _ => e, @@ -142,17 +142,21 @@ type state = { fun kind (k, st) = (k, st) -fun exp ((ks, ts), e, st : state) = +fun exp ((ks, ts), e as old, st : state) = case e of ELet (eds, e) => let + (*val () = Print.prefaces "let" [("e", ElabPrint.p_exp E.empty (old, ErrorMsg.dummySpan))]*) + val doSubst = foldl (fn (p, e) => E.subExpInExp p e) - val (eds, (maxName, ds, subs)) = + val (eds, (ts, maxName, ds, subs)) = ListUtil.foldlMapConcat - (fn (ed, (maxName, ds, subs)) => + (fn (ed, (ts, maxName, ds, subs)) => case #1 ed of - EDVal _ => ([ed], (maxName, ds, map (fn (n, e) => (n + 1, E.liftExpInExp 0 e)) subs)) + EDVal (x, t, _) => ([ed], + ((x, t) :: ts, + maxName, ds, map (fn (n, e) => (n + 1, E.liftExpInExp 0 e)) subs)) | EDValRec vis => let val loc = #2 ed @@ -174,7 +178,10 @@ fun exp ((ks, ts), e, st : state) = end) (IS.empty, IS.empty) vis - (*val () = print ("A: " ^ Int.toString (length ts) ^ ", " ^ Int.toString (length ks) ^ "\n")*) + (*val () = print ("A: " ^ Int.toString (length ts) ^ ", " ^ Int.toString (length ks) ^ "\n") + val () = app (fn (x, t) => + Print.prefaces "Var" [("x", Print.PD.string x), + ("t", ElabPrint.p_con E.empty t)]) ts*) val cfv = IS.foldl (fn (x, cfv) => let (*val () = print (Int.toString x ^ "\n")*) @@ -193,11 +200,11 @@ fun exp ((ks, ts), e, st : state) = fun apply e = let - val e = IS.foldl (fn (x, e) => + val e = IS.foldr (fn (x, e) => (ECApp (e, (CRel x, loc)), loc)) e cfv in - IS.foldl (fn (x, e) => + IS.foldr (fn (x, e) => (EApp (e, (ERel x, loc)), loc)) e efv end @@ -237,9 +244,9 @@ fun exp ((ks, ts), e, st : state) = val t = squishCon cfv t (*val () = Print.prefaces "squishExp" [("e", ElabPrint.p_exp E.empty e)]*) - val e = squishExp (nr, cfv, efv) e + val e = squishExp (0(*nr*), cfv, efv) e - val (e, t) = foldr (fn (ex, (e, t)) => + val (e, t) = foldl (fn (ex, (e, t)) => let val (name, t') = List.nth (ts, ex) in @@ -252,7 +259,7 @@ fun exp ((ks, ts), e, st : state) = end) (e, t) efv - val (e, t) = foldr (fn (cx, (e, t)) => + val (e, t) = foldl (fn (cx, (e, t)) => let val (name, k) = List.nth (ks, cx) in @@ -272,10 +279,12 @@ fun exp ((ks, ts), e, st : state) = vis val d = (DValRec vis, #2 ed) + + val ts = map (fn (x, _, t, _) => (x, t)) vis @ ts in - ([], (maxName, d :: ds, subs)) + ([], (ts, maxName, d :: ds, subs)) end) - (#maxName st, #decls st, []) eds + (ts, #maxName st, #decls st, []) eds in (ELet (eds, doSubst e subs), {maxName = maxName, diff --git a/tests/blog.ur b/tests/blog.ur new file mode 100644 index 00000000..a3a06cb6 --- /dev/null +++ b/tests/blog.ur @@ -0,0 +1,16 @@ +fun main wrap = + let + fun edit id = + let + val r = 0 + fun save () = + in + wrap (save ()) + end + in + edit 0 + end + +fun wrap (inside : xbody) = return + +val main () = main wrap diff --git a/tests/blog.urp b/tests/blog.urp new file mode 100644 index 00000000..a3f7bfaa --- /dev/null +++ b/tests/blog.urp @@ -0,0 +1,4 @@ +debug +database dbname=blog + +blog \ No newline at end of file diff --git a/tests/blog.urs b/tests/blog.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/blog.urs @@ -0,0 +1 @@ +val main : unit -> transaction page diff --git a/tests/nest.ur b/tests/nest.ur index 8da50712..96bfdff4 100644 --- a/tests/nest.ur +++ b/tests/nest.ur @@ -45,7 +45,26 @@ fun f (x : int) = page3 end -datatype list t = Nil | Cons of t * list t +fun add2 (x : int) (y : int) = + let + fun add3 () = x + y + in + add3 + end + +fun add3 (x : int) = + let + fun add2 (y : int) = + let + fun add1 (z : int) = x + y + z + in + add1 + end + in + add2 + end + +(*datatype list t = Nil | Cons of t * list t fun length (t ::: Type) (ls : list t) = let @@ -57,3 +76,4 @@ fun length (t ::: Type) (ls : list t) = length' ls 0 end +*) diff --git a/tests/nest2.ur b/tests/nest2.ur new file mode 100644 index 00000000..9a1d271a --- /dev/null +++ b/tests/nest2.ur @@ -0,0 +1,15 @@ +fun wooho (wrap : xbody -> transaction page) = + let + fun subPage n = + let + fun subberPage () = wrap {[n]} + in + wrap Go + end + in + subPage 0 + end + +fun wrap x = return {x} + +fun main () = wooho wrap diff --git a/tests/nest2.urp b/tests/nest2.urp new file mode 100644 index 00000000..2668c65e --- /dev/null +++ b/tests/nest2.urp @@ -0,0 +1,3 @@ +debug + +nest2 -- cgit v1.2.3 From 24483b49c81a6ac1c99cd28ca3505150b5999863 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 1 Nov 2008 21:24:43 -0400 Subject: Nested save compiles --- src/compiler.sig | 2 + src/compiler.sml | 9 ++- src/core_untangle.sig | 32 ++++++++ src/core_untangle.sml | 215 ++++++++++++++++++++++++++++++++++++++++++++++++++ src/sources | 3 + 5 files changed, 260 insertions(+), 1 deletion(-) create mode 100644 src/core_untangle.sig create mode 100644 src/core_untangle.sml diff --git a/src/compiler.sig b/src/compiler.sig index bc1974a1..6094da89 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -63,6 +63,7 @@ signature COMPILER = sig val explify : (Elab.file, Expl.file) phase val corify : (Expl.file, Core.file) phase val especialize : (Core.file, Core.file) phase + val core_untangle : (Core.file, Core.file) phase val shake : (Core.file, Core.file) phase val tag : (Core.file, Core.file) phase val reduce : (Core.file, Core.file) phase @@ -86,6 +87,7 @@ signature COMPILER = sig val toExplify : (string, Expl.file) transform val toCorify : (string, Core.file) transform val toEspecialize : (string, Core.file) transform + val toCore_untangle : (string, Core.file) transform val toShake1 : (string, Core.file) transform val toTag : (string, Core.file) transform val toReduce : (string, Core.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index e92f86c3..1124bfda 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -418,12 +418,19 @@ val especialize = { val toEspecialize = transform especialize "especialize" o toCorify +val core_untangle = { + func = CoreUntangle.untangle, + print = CorePrint.p_file CoreEnv.empty +} + +val toCore_untangle = transform core_untangle "core_untangle" o toEspecialize + val shake = { func = Shake.shake, print = CorePrint.p_file CoreEnv.empty } -val toShake1 = transform shake "shake1" o toEspecialize +val toShake1 = transform shake "shake1" o toCore_untangle val tag = { func = Tag.tag, diff --git a/src/core_untangle.sig b/src/core_untangle.sig new file mode 100644 index 00000000..86e039e4 --- /dev/null +++ b/src/core_untangle.sig @@ -0,0 +1,32 @@ +(* 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. + *) + +signature CORE_UNTANGLE = sig + + val untangle : Core.file -> Core.file + +end diff --git a/src/core_untangle.sml b/src/core_untangle.sml new file mode 100644 index 00000000..6f424614 --- /dev/null +++ b/src/core_untangle.sml @@ -0,0 +1,215 @@ +(* 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. + *) + +structure CoreUntangle :> CORE_UNTANGLE = struct + +open Core + +structure U = CoreUtil +structure E = CoreEnv + +structure IS = IntBinarySet +structure IM = IntBinaryMap + +fun default (k, s) = s + +fun exp (e, s) = + case e of + ENamed n => IS.add (s, n) + + | _ => s + +fun untangle file = + let + fun decl (dAll as (d, loc)) = + case d of + DValRec vis => + let + val thisGroup = foldl (fn ((_, n, _, _, _), thisGroup) => + IS.add (thisGroup, n)) IS.empty vis + + val used = foldl (fn ((_, n, _, e, _), used) => + let + val usedHere = U.Exp.fold {con = default, + kind = default, + exp = exp} IS.empty e + in + IM.insert (used, n, IS.intersection (usedHere, thisGroup)) + end) + IM.empty vis + + fun p_graph reachable = + IM.appi (fn (n, reachableHere) => + (print (Int.toString n); + print ":"; + IS.app (fn n' => (print " "; + print (Int.toString n'))) reachableHere; + print "\n")) reachable + + (*val () = print "used:\n" + val () = p_graph used*) + + fun expand reachable = + let + val changed = ref false + + val reachable = + IM.mapi (fn (n, reachableHere) => + IS.foldl (fn (n', reachableHere) => + let + val more = valOf (IM.find (reachable, n')) + in + if IS.isEmpty (IS.difference (more, reachableHere)) then + reachableHere + else + (changed := true; + IS.union (more, reachableHere)) + end) + reachableHere reachableHere) reachable + in + (reachable, !changed) + end + + fun iterate reachable = + let + val (reachable, changed) = expand reachable + in + if changed then + iterate reachable + else + reachable + end + + val reachable = iterate used + + (*val () = print "reachable:\n" + val () = p_graph reachable*) + + fun sccs (nodes, acc) = + case IS.find (fn _ => true) nodes of + NONE => acc + | SOME rep => + let + val reachableHere = valOf (IM.find (reachable, rep)) + + val (nodes, scc) = IS.foldl (fn (node, (nodes, scc)) => + if node = rep then + (nodes, scc) + else + let + val reachableThere = + valOf (IM.find (reachable, node)) + in + if IS.member (reachableThere, rep) then + (IS.delete (nodes, node), + IS.add (scc, node)) + else + (nodes, scc) + end) + (IS.delete (nodes, rep), IS.singleton rep) reachableHere + in + sccs (nodes, scc :: acc) + end + + val sccs = sccs (thisGroup, []) + (*val () = app (fn nodes => (print "SCC:"; + IS.app (fn i => (print " "; + print (Int.toString i))) nodes; + print "\n")) sccs*) + + fun depends nodes1 nodes2 = + let + val node1 = valOf (IS.find (fn _ => true) nodes1) + val node2 = valOf (IS.find (fn _ => true) nodes2) + val reachable1 = valOf (IM.find (reachable, node1)) + in + IS.member (reachable1, node2) + end + + fun findReady (sccs, passed) = + case sccs of + [] => raise Fail "Untangle: Unable to topologically sort 'val rec'" + | nodes :: sccs => + if List.exists (depends nodes) passed + orelse List.exists (depends nodes) sccs then + findReady (sccs, nodes :: passed) + else + (nodes, List.revAppend (passed, sccs)) + + fun topo (sccs, acc) = + case sccs of + [] => rev acc + | _ => + let + val (node, sccs) = findReady (sccs, []) + in + topo (sccs, node :: acc) + end + + val sccs = topo (sccs, []) + (*val () = app (fn nodes => (print "SCC':"; + IS.app (fn i => (print " "; + print (Int.toString i))) nodes; + print "\n")) sccs*) + + fun isNonrec nodes = + case IS.find (fn _ => true) nodes of + NONE => NONE + | SOME node => + let + val nodes = IS.delete (nodes, node) + val reachableHere = valOf (IM.find (reachable, node)) + in + if IS.isEmpty nodes then + if IS.member (reachableHere, node) then + NONE + else + SOME node + else + NONE + end + + val ds = map (fn nodes => + case isNonrec nodes of + SOME node => + let + val vi = valOf (List.find (fn (_, n, _, _, _) => n = node) vis) + in + (DVal vi, loc) + end + | NONE => + (DValRec (List.filter (fn (_, n, _, _, _) => IS.member (nodes, n)) vis), loc)) + sccs + in + ds + end + | _ => [dAll] + in + ListUtil.mapConcat decl file + end + +end diff --git a/src/sources b/src/sources index 504013d8..9fd90e8c 100644 --- a/src/sources +++ b/src/sources @@ -99,6 +99,9 @@ specialize.sml especialize.sig especialize.sml +core_untangle.sig +core_untangle.sml + tag.sig tag.sml -- cgit v1.2.3 From 627c93b9779f632bd8d90e7e2de26a5a9c197f08 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 4 Nov 2008 09:33:35 -0500 Subject: Nested demo --- demo/crud.ur | 8 +++---- demo/nested.ur | 62 +++++++++++++++++++++++++++++++++++++++++++++++++++ demo/nested.urp | 2 ++ demo/nested.urs | 1 + demo/prose | 4 ++++ src/core_untangle.sml | 36 ++++++++++++++++++++++++++---- src/unnest.sml | 13 ++++++----- 7 files changed, 113 insertions(+), 13 deletions(-) create mode 100644 demo/nested.ur create mode 100644 demo/nested.urp create mode 100644 demo/nested.urs diff --git a/demo/crud.ur b/demo/crud.ur index 77fccf16..ee6a95f6 100644 --- a/demo/crud.ur +++ b/demo/crud.ur @@ -100,9 +100,9 @@ functor Make(M : sig sql_exp [] [] [] t.1) cols)] (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) [[nm] ~ rest] => - fn input col acc => acc with nm = @sql_inject col.Inject (col.Parse input)) + fn input col acc => acc ++ {nm = @sql_inject col.Inject (col.Parse input)}) {} [M.cols] inputs M.cols - with #Id = (SQL {id}))); + ++ {Id = (SQL {id})})); ls <- list (); return

    Inserted with ID {[id]}.

    @@ -119,8 +119,8 @@ functor Make(M : sig [] [] t.1) cols)] (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) [[nm] ~ rest] => - fn input col acc => acc with nm = - @sql_inject col.Inject (col.Parse input)) + fn input col acc => acc ++ {nm = + @sql_inject col.Inject (col.Parse input)}) {} [M.cols] inputs M.cols) tab (WHERE T.Id = {id})); ls <- list (); diff --git a/demo/nested.ur b/demo/nested.ur new file mode 100644 index 00000000..31c9e1e8 --- /dev/null +++ b/demo/nested.ur @@ -0,0 +1,62 @@ +fun pageA () = return + + A + + +
    + + + + + + + + + +
    Forename:
    Enter a Surname?
    + + + +
     + +and fromA r = + let + val forename = r.Forename + + fun pageB () = return + + B + + +
    + Surname: + + + + Previous + +
    + + and pageC' r = pageC (Some r.Surname) + + and pageC surname = return + + C + + +

    Hello {[forename]}{case surname of + None => + | Some s => {[s]}}

    + {case surname of + None => Previous + | Some _ => Previous} + +     + in + if r.EnterSurname then + pageB () + else + pageC None + end + +val main = pageA diff --git a/demo/nested.urp b/demo/nested.urp new file mode 100644 index 00000000..179014dc --- /dev/null +++ b/demo/nested.urp @@ -0,0 +1,2 @@ + +nested diff --git a/demo/nested.urs b/demo/nested.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/demo/nested.urs @@ -0,0 +1 @@ +val main : unit -> transaction page diff --git a/demo/prose b/demo/prose index 3b9d9ebb..06c47722 100644 --- a/demo/prose +++ b/demo/prose @@ -54,6 +54,10 @@ form.urp

    Here we see a basic form. The type system tracks which form inputs we include, and it enforces that the form handler function expects a record containing exactly those fields, with exactly the proper types.

    +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.

    + listShop.urp

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

    diff --git a/src/core_untangle.sml b/src/core_untangle.sml index 6f424614..ededded0 100644 --- a/src/core_untangle.sml +++ b/src/core_untangle.sml @@ -45,6 +45,15 @@ fun exp (e, s) = fun untangle file = let + val edefs = foldl (fn ((d, _), edefs) => + case d of + DVal (_, n, _, e, _) => IM.insert (edefs, n, e) + | DValRec vis => + foldl (fn ((_, n, _, e, _), edefs) => + IM.insert (edefs, n, e)) edefs vis + | _ => edefs) + IM.empty file + fun decl (dAll as (d, loc)) = case d of DValRec vis => @@ -52,16 +61,35 @@ fun untangle file = val thisGroup = foldl (fn ((_, n, _, _, _), thisGroup) => IS.add (thisGroup, n)) IS.empty vis + val expUsed = U.Exp.fold {con = default, + kind = default, + exp = exp} IS.empty + val used = foldl (fn ((_, n, _, e, _), used) => let - val usedHere = U.Exp.fold {con = default, - kind = default, - exp = exp} IS.empty e + val usedHere = expUsed e in - IM.insert (used, n, IS.intersection (usedHere, thisGroup)) + IM.insert (used, n, usedHere) end) IM.empty vis + fun expand used = + IS.foldl (fn (n, used) => + case IM.find (edefs, n) of + NONE => used + | SOME e => + let + val usedHere = expUsed e + in + if IS.isEmpty (IS.difference (usedHere, used)) then + used + else + expand (IS.union (usedHere, used)) + end) + used used + + val used = IM.map (fn s => IS.intersection (expand s, thisGroup)) used + fun p_graph reachable = IM.appi (fn (n, reachableHere) => (print (Int.toString n); diff --git a/src/unnest.sml b/src/unnest.sml index f226a678..b56daf8a 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -137,7 +137,7 @@ fun squishExp (nr, cfv, efv) = type state = { maxName : int, - decls : decl list + decls : (string * int * con * exp) list } fun kind (k, st) = (k, st) @@ -278,11 +278,9 @@ fun exp ((ks, ts), e as old, st : state) = end) vis - val d = (DValRec vis, #2 ed) - val ts = map (fn (x, _, t, _) => (x, t)) vis @ ts in - ([], (ts, maxName, d :: ds, subs)) + ([], (ts, maxName, vis @ ds, subs)) end) (ts, #maxName st, #decls st, []) eds in @@ -319,8 +317,13 @@ fun unnest file = fun explore () = let val (d, st) = unnestDecl st all + + val ds = + case #1 d of + DValRec vis => [(DValRec (vis @ #decls st), #2 d)] + | _ => [(DValRec (#decls st), #2 d), d] in - (rev (d :: #decls st), + (ds, {maxName = #maxName st, decls = []}) end -- cgit v1.2.3 From 1841f3b75ec441d16d289cb768526c374f16960a Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 09:21:34 -0500 Subject: Monoizing FFI transactions correctly --- lib/basis.urs | 23 ++++++++++----- src/corify.sml | 81 ++++++++++++++++++++++++++++++++++++++++++++--------- src/mono_reduce.sml | 11 ++++++-- tests/reqheader.ur | 5 ++++ tests/reqheader.urp | 3 ++ 5 files changed, 99 insertions(+), 24 deletions(-) create mode 100644 tests/reqheader.ur create mode 100644 tests/reqheader.urp diff --git a/lib/basis.urs b/lib/basis.urs index ca81c95f..806a9623 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -69,6 +69,22 @@ val read_bool : read bool val read_time : read time +(** * Transactions *) + +con transaction :: Type -> Type + +val return : t ::: Type + -> t -> transaction t +val bind : t1 ::: Type -> t2 ::: Type + -> transaction t1 -> (t1 -> transaction t2) + -> transaction t2 + + +(** HTTP operations *) + +val requestHeader : string -> transaction (option string) + + (** SQL *) con sql_table :: {Type} -> Type @@ -233,13 +249,6 @@ val sql_current_timestamp : sql_nfunc time (*** Executing queries *) -con transaction :: Type -> Type -val return : t ::: Type - -> t -> transaction t -val bind : t1 ::: Type -> t2 ::: Type - -> transaction t1 -> (t1 -> transaction t2) - -> transaction t2 - val query : tables ::: {{Type}} -> exps ::: {Type} -> fn [tables ~ exps] => state ::: Type diff --git a/src/corify.sml b/src/corify.sml index 0ec98c69..8b72f9f8 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -540,11 +540,31 @@ fun corifyExp st (e, loc) = | _ => (all, rev args) val (result, args) = getArgs (t, []) + val (isTransaction, result) = + case result of + (L'.CApp ((L'.CFfi ("Basis", "transaction"), _), + result), _) => (true, result) + | _ => (false, result) - val (actuals, _) = foldr (fn (_, (actuals, n)) => - ((L'.ERel n, loc) :: actuals, - n + 1)) ([], 0) args - val app = (L'.EFfiApp (m, x, actuals), loc) + fun makeApp n = + let + val (actuals, _) = foldr (fn (_, (actuals, n)) => + ((L'.ERel n, loc) :: actuals, + n + 1)) ([], n) args + in + (L'.EFfiApp (m, x, actuals), loc) + end + val unit = (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc) + val (result, app) = + if isTransaction then + ((L'.TFun (unit, result), loc), + (L'.EAbs ("_", + unit, + result, + makeApp 1), loc)) + else + (result, makeApp 0) + val (abs, _, _) = foldr (fn (t, (abs, ran, n)) => ((L'.EAbs ("arg" ^ Int.toString n, t, @@ -734,17 +754,24 @@ fun corifyDecl mods ((d, loc : EM.span), st) = (case sgn of L.SgnConst sgis => let - val (ds, cmap, conmap, st) = - foldl (fn ((sgi, _), (ds, cmap, conmap, st)) => + val (ds, cmap, conmap, st, _) = + foldl (fn ((sgi, _), (ds, cmap, conmap, st, trans)) => case sgi of L.SgiConAbs (x, n, k) => let val (st, n') = St.bindCon st x n + + val trans = + if x = "transaction" then + SOME n + else + trans in ((L'.DCon (x, n', corifyKind k, (L'.CFfi (m, x), loc)), loc) :: ds, cmap, conmap, - st) + st, + trans) end | L.SgiCon (x, n, k, _) => let @@ -753,7 +780,8 @@ fun corifyDecl mods ((d, loc : EM.span), st) = ((L'.DCon (x, n', corifyKind k, (L'.CFfi (m, x), loc)), loc) :: ds, cmap, conmap, - st) + st, + trans) end | L.SgiDatatype (x, n, xs, xnts) => @@ -815,15 +843,40 @@ fun corifyDecl mods ((d, loc : EM.span), st) = (ds' @ (L'.DDatatype (x, n', xs, xnts), loc) :: ds, cmap, conmap, - st) + st, + trans) end | L.SgiVal (x, _, c) => - (ds, - SM.insert (cmap, x, corifyCon st c), - conmap, - st) - | _ => (ds, cmap, conmap, st)) ([], SM.empty, SM.empty, st) sgis + let + val c = + case trans of + NONE => corifyCon st c + | SOME trans => + let + fun transactify (all as (c, loc)) = + case c of + L.TFun (dom, ran) => + (L'.TFun (corifyCon st dom, transactify ran), loc) + | L.CApp ((L.CNamed trans', _), t) => + if trans' = trans then + (L'.CApp ((L'.CFfi (m, "transaction"), loc), + corifyCon st t), loc) + else + corifyCon st all + | _ => corifyCon st all + in + transactify c + end + in + (ds, + SM.insert (cmap, x, c), + conmap, + st, + trans) + end + | _ => (ds, cmap, conmap, st, trans)) + ([], SM.empty, SM.empty, st, NONE) sgis val st = St.bindStr st m n (St.ffi m cmap conmap) in diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 07c7c5f5..57a9cc6d 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -352,10 +352,15 @@ fun exp env e = | ELet (x, t, e', b) => let + fun doSub () = #1 (reduceExp env (subExpInExp (0, e') b)) + fun trySub () = - case e' of - (ECase _, _) => e - | _ => #1 (reduceExp env (subExpInExp (0, e') b)) + case t of + (TFfi ("Basis", "string"), _) => doSub () + | _ => + case e' of + (ECase _, _) => e + | _ => doSub () in if impure e' then let diff --git a/tests/reqheader.ur b/tests/reqheader.ur new file mode 100644 index 00000000..8b69cc3a --- /dev/null +++ b/tests/reqheader.ur @@ -0,0 +1,5 @@ +fun main () : transaction page = + ua <- requestHeader "UserAgent"; + case ua of + None => return Not found + | Some s => return UserAgent: {[s]} diff --git a/tests/reqheader.urp b/tests/reqheader.urp new file mode 100644 index 00000000..4541390f --- /dev/null +++ b/tests/reqheader.urp @@ -0,0 +1,3 @@ +debug + +reqheader -- cgit v1.2.3 From 4f82d607ed4549ecb4bea8ebfc93cfa1b1cec8d2 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 09:47:16 -0500 Subject: Request header reading works --- include/urweb.h | 4 +++- src/c/driver.c | 5 +++-- src/c/urweb.c | 34 +++++++++++++++++++++++++++++++++- src/compiler.sml | 6 +++--- tests/reqheader.ur | 4 ++-- 5 files changed, 44 insertions(+), 9 deletions(-) diff --git a/include/urweb.h b/include/urweb.h index 43a63324..c7d15a1c 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -15,7 +15,7 @@ void uw_reset_keep_request(uw_context); void uw_reset_keep_error_message(uw_context); failure_kind uw_begin_init(uw_context); -failure_kind uw_begin(uw_context, char *path); +failure_kind uw_begin(uw_context, char *headers, char *path); __attribute__((noreturn)) void uw_error(uw_context, failure_kind, const char *fmt, ...); char *uw_error_message(uw_context); @@ -95,3 +95,5 @@ 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); + +uw_Basis_string uw_Basis_requestHeader(uw_context, uw_Basis_string); diff --git a/src/c/driver.c b/src/c/driver.c index db982d96..4c54d3ba 100644 --- a/src/c/driver.c +++ b/src/c/driver.c @@ -135,7 +135,7 @@ static void *worker(void *data) { if (s = strstr(buf, "\r\n\r\n")) { failure_kind fk; - char *cmd, *path, path_copy[uw_bufsize+1], *inputs; + char *cmd, *path, *headers, path_copy[uw_bufsize+1], *inputs; *s = 0; @@ -145,6 +145,7 @@ static void *worker(void *data) { } *s = 0; + headers = s + 2; cmd = s = buf; printf("Read: %s\n", buf); @@ -208,7 +209,7 @@ static void *worker(void *data) { uw_write(ctx, ""); strcpy(path_copy, path); - fk = uw_begin(ctx, path_copy); + fk = uw_begin(ctx, headers, path_copy); if (fk == SUCCESS) { uw_write(ctx, ""); diff --git a/src/c/urweb.c b/src/c/urweb.c index f05b0b9d..9e83191e 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -3,6 +3,7 @@ #include #include #include +#include #include #include #include @@ -23,6 +24,8 @@ typedef struct { } cleanup; struct uw_context { + char *headers; + char *page, *page_front, *page_back; char *heap, *heap_front, *heap_back; char **inputs; @@ -43,6 +46,8 @@ extern int uw_inputs_len; uw_context uw_init(size_t page_len, size_t heap_len) { uw_context ctx = malloc(sizeof(struct uw_context)); + ctx->headers = NULL; + ctx->page_front = ctx->page = malloc(page_len); ctx->page_back = ctx->page_front + page_len; @@ -111,9 +116,11 @@ failure_kind uw_begin_init(uw_context ctx) { return r; } -failure_kind uw_begin(uw_context ctx, char *path) { +failure_kind uw_begin(uw_context ctx, char *headers, char *path) { int r = setjmp(ctx->jmp_buf); + ctx->headers = headers; + if (r == 0) uw_handle(ctx, path); @@ -1051,3 +1058,28 @@ uw_Basis_time uw_Basis_stringToTime_error(uw_context ctx, uw_Basis_string s) { uw_error(ctx, FATAL, "Can't parse time: %s", s); } } + +uw_Basis_string uw_Basis_requestHeader(uw_context ctx, uw_Basis_string h) { + int len = strlen(h); + char *s = ctx->headers, *p; + + while (p = strchr(s, ':')) { + if (p - s == len && !strncasecmp(s, h, len)) { + s = p + 2; + if (p = strchr(s, '\r')) { + uw_Basis_string ret = uw_malloc(ctx, p - s + 1); + memcpy(ret, s, p - s); + ret[p - s] = 0; + return ret; + } + else + return NULL; + } else { + if (s = strchr(s, '\n')) + ++s; + else + return NULL; + } + } + +} diff --git a/src/compiler.sml b/src/compiler.sml index 1124bfda..de0490c3 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -552,7 +552,7 @@ fun compile job = val (cname, oname, cleanup) = if #debug job then - ("/tmp/urweb.c", "/tmp/urweb.o", fn () => ()) + ("/tmp/webapp.c", "/tmp/webapp.o", fn () => ()) else let val dir = OS.FileSys.tmpName () @@ -560,8 +560,8 @@ fun compile job = OS.FileSys.remove dir else () - val cname = OS.Path.joinDirFile {dir = dir, file = "urweb.c"} - val oname = OS.Path.joinDirFile {dir = dir, file = "urweb.o"} + val cname = OS.Path.joinDirFile {dir = dir, file = "webapp.c"} + val oname = OS.Path.joinDirFile {dir = dir, file = "webapp.o"} in OS.FileSys.mkDir dir; (cname, oname, diff --git a/tests/reqheader.ur b/tests/reqheader.ur index 8b69cc3a..d659935c 100644 --- a/tests/reqheader.ur +++ b/tests/reqheader.ur @@ -1,5 +1,5 @@ fun main () : transaction page = - ua <- requestHeader "UserAgent"; + ua <- requestHeader "User-Agent"; case ua of None => return Not found - | Some s => return UserAgent: {[s]} + | Some s => return User-Agent: {[s]} -- cgit v1.2.3 From 45dee9afc8f0b8030115943af95df499ba8ee13e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 10:04:03 -0500 Subject: Avoid allocating strings for requestHeader --- include/urweb.h | 3 ++- src/c/driver.c | 4 +++- src/c/urweb.c | 41 ++++++++++++++++++++++++----------------- 3 files changed, 29 insertions(+), 19 deletions(-) diff --git a/include/urweb.h b/include/urweb.h index c7d15a1c..301129c5 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -15,7 +15,8 @@ void uw_reset_keep_request(uw_context); void uw_reset_keep_error_message(uw_context); failure_kind uw_begin_init(uw_context); -failure_kind uw_begin(uw_context, char *headers, char *path); +void uw_set_headers(uw_context, char *headers); +failure_kind uw_begin(uw_context, char *path); __attribute__((noreturn)) void uw_error(uw_context, failure_kind, const char *fmt, ...); char *uw_error_message(uw_context); diff --git a/src/c/driver.c b/src/c/driver.c index 4c54d3ba..ac968dc9 100644 --- a/src/c/driver.c +++ b/src/c/driver.c @@ -188,6 +188,8 @@ static void *worker(void *data) { printf("Serving URI %s....\n", path); + uw_set_headers(ctx, headers); + while (1) { if (uw_db_begin(ctx)) { printf("Error running SQL BEGIN\n"); @@ -209,7 +211,7 @@ static void *worker(void *data) { uw_write(ctx, ""); strcpy(path_copy, path); - fk = uw_begin(ctx, headers, path_copy); + fk = uw_begin(ctx, path_copy); if (fk == SUCCESS) { uw_write(ctx, ""); diff --git a/src/c/urweb.c b/src/c/urweb.c index 9e83191e..5f718db6 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -24,7 +24,7 @@ typedef struct { } cleanup; struct uw_context { - char *headers; + char *headers, *headers_end; char *page, *page_front, *page_back; char *heap, *heap_front, *heap_back; @@ -46,7 +46,7 @@ extern int uw_inputs_len; uw_context uw_init(size_t page_len, size_t heap_len) { uw_context ctx = malloc(sizeof(struct uw_context)); - ctx->headers = NULL; + ctx->headers = ctx->headers_end = NULL; ctx->page_front = ctx->page = malloc(page_len); ctx->page_back = ctx->page_front + page_len; @@ -116,11 +116,26 @@ failure_kind uw_begin_init(uw_context ctx) { return r; } -failure_kind uw_begin(uw_context ctx, char *headers, char *path) { - int r = setjmp(ctx->jmp_buf); - +void uw_set_headers(uw_context ctx, char *headers) { + char *s = headers, *s2; ctx->headers = headers; + while (s2 = strchr(s, '\r')) { + s = s2; + + if (s[1] == 0) + break; + + *s = 0; + s += 2; + } + + ctx->headers_end = s; +} + +failure_kind uw_begin(uw_context ctx, char *path) { + int r = setjmp(ctx->jmp_buf); + if (r == 0) uw_handle(ctx, path); @@ -1065,21 +1080,13 @@ uw_Basis_string uw_Basis_requestHeader(uw_context ctx, uw_Basis_string h) { while (p = strchr(s, ':')) { if (p - s == len && !strncasecmp(s, h, len)) { - s = p + 2; - if (p = strchr(s, '\r')) { - uw_Basis_string ret = uw_malloc(ctx, p - s + 1); - memcpy(ret, s, p - s); - ret[p - s] = 0; - return ret; - } - else - return NULL; + return p + 2; } else { - if (s = strchr(s, '\n')) - ++s; + if ((s = strchr(p, 0)) && s < ctx->headers_end) + s += 2; else return NULL; } } - + } -- cgit v1.2.3 From 12bb99a0ba702af12e89bfe544f2a572e5d4818d Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 10:29:55 -0500 Subject: Cookies through elaborate --- lib/basis.urs | 4 +++ src/elab.sml | 2 ++ src/elab_env.sml | 15 +++++++++++ src/elab_print.sml | 14 +++++++++++ src/elab_util.sml | 27 +++++++++++++++----- src/elaborate.sml | 66 ++++++++++++++++++++++++++++++++++++++++++++++++- src/elisp/urweb-defs.el | 6 ++--- src/elisp/urweb-mode.el | 4 +-- src/source.sml | 2 ++ src/source_print.sml | 15 +++++++++++ src/unnest.sml | 1 + src/urweb.grm | 3 +++ src/urweb.lex | 1 + tests/cookie.ur | 9 +++++++ tests/cookie.urp | 3 +++ 15 files changed, 160 insertions(+), 12 deletions(-) create mode 100644 tests/cookie.ur create mode 100644 tests/cookie.urp diff --git a/lib/basis.urs b/lib/basis.urs index 806a9623..84fb4e4c 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -84,6 +84,10 @@ val bind : t1 ::: Type -> t2 ::: Type val requestHeader : string -> transaction (option string) +con http_cookie :: Type -> Type +val getCookie : t ::: Type -> http_cookie t -> transaction (option t) +val setCookie : t ::: Type -> http_cookie t -> t -> transaction unit + (** SQL *) diff --git a/src/elab.sml b/src/elab.sml index b5350c2a..afb8f7aa 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -139,6 +139,7 @@ datatype sgn_item' = | SgiSequence of int * string * int | SgiClassAbs of string * int | SgiClass of string * int * con + | SgiCookie of int * string * int * con and sgn' = SgnConst of sgn_item list @@ -166,6 +167,7 @@ datatype decl' = | DSequence of int * string * int | DClass of string * int * con | DDatabase of string + | DCookie of int * string * int * con and str' = StrConst of decl list diff --git a/src/elab_env.sml b/src/elab_env.sml index 6b762abd..a782771a 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -592,6 +592,7 @@ fun sgiSeek (sgi, (sgns, strs, cons)) = | SgiSequence _ => (sgns, strs, cons) | SgiClassAbs (x, n) => (sgns, strs, IM.insert (cons, n, x)) | SgiClass (x, n, _) => (sgns, strs, IM.insert (cons, n, x)) + | SgiCookie _ => (sgns, strs, cons) fun sgnSeek f sgis = let @@ -945,6 +946,13 @@ fun sgiBinds env (sgi, loc) = | SgiClassAbs (x, n) => pushCNamedAs env x n (KArrow ((KType, loc), (KType, loc)), loc) NONE | SgiClass (x, n, c) => pushCNamedAs env x n (KArrow ((KType, loc), (KType, loc)), loc) (SOME c) + + | SgiCookie (tn, x, n, c) => + let + val t = (CApp ((CModProj (tn, [], "http_cookie"), loc), c), loc) + in + pushENamedAs env x n t + end fun sgnSubCon x = @@ -1095,6 +1103,7 @@ fun sgnSeekConstraints (str, sgis) = | SgiSequence _ => seek (sgis, sgns, strs, cons, acc) | SgiClassAbs (x, n) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) | SgiClass (x, n, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) + | SgiCookie _ => seek (sgis, sgns, strs, cons, acc) in seek (sgis, IM.empty, IM.empty, IM.empty, []) end @@ -1189,6 +1198,12 @@ fun declBinds env (d, loc) = pushClass env n end | DDatabase _ => env + | DCookie (tn, x, n, c) => + let + val t = (CApp ((CModProj (tn, [], "cookie"), loc), c), loc) + in + pushENamedAs env x n t + end fun patBinds env (p, loc) = case p of diff --git a/src/elab_print.sml b/src/elab_print.sml index b236954e..a686abe5 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -536,6 +536,13 @@ fun p_sgn_item env (sgi, _) = string "=", space, p_con env c] + | SgiCookie (_, x, n, c) => box [string "cookie", + space, + p_named x n, + space, + string ":", + space, + p_con env c] and p_sgn env (sgn, _) = case sgn of @@ -707,6 +714,13 @@ fun p_decl env (dAll as (d, _) : decl) = | DDatabase s => box [string "database", space, string s] + | DCookie (_, x, n, c) => box [string "cookie", + space, + p_named x n, + space, + string ":", + space, + p_con env c] and p_str env (str, _) = case str of diff --git a/src/elab_util.sml b/src/elab_util.sml index 57a94486..fe75ee0d 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -548,6 +548,10 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = S.map2 (con ctx c, fn c' => (SgiClass (x, n, c'), loc)) + | SgiCookie (tn, x, n, c) => + S.map2 (con ctx c, + fn c' => + (SgiCookie (tn, x, n, c'), loc)) and sg ctx s acc = S.bindP (sg' ctx s acc, sgn ctx) @@ -576,7 +580,8 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = | SgiClassAbs (x, n) => bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))) | SgiClass (x, n, _) => - bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))), + bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))) + | SgiCookie _ => ctx, sgi ctx si)) ctx sgis, fn sgis' => (SgnConst sgis', loc)) @@ -720,7 +725,10 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f bind (ctx, NamedE (x, (CModProj (n, [], "sql_sequence"), loc))) | DClass (x, n, _) => bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))) - | DDatabase _ => ctx, + | DDatabase _ => ctx + | DCookie (tn, x, n, c) => + bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "cookie"), loc), + c), loc))), mfd ctx d)) ctx ds, fn ds' => (StrConst ds', loc)) | StrVar _ => S.return2 strAll @@ -821,6 +829,11 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f | DDatabase _ => S.return2 dAll + | DCookie (tn, x, n, c) => + S.map2 (mfc ctx c, + fn c' => + (DCookie (tn, x, n, c'), loc)) + and mfvi ctx (x, n, c, e) = S.bind2 (mfc ctx c, fn c' => @@ -955,9 +968,10 @@ and maxNameDecl (d, _) = | DConstraint _ => 0 | DClass (_, n, _) => n | DExport _ => 0 - | DTable (n, _, _, _) => n - | DSequence (n, _, _) => n + | DTable (n1, _, n2, _) => Int.max (n1, n2) + | DSequence (n1, _, n2) => Int.max (n1, n2) | DDatabase _ => 0 + | DCookie (n1, _, n2, _) => Int.max (n1, n2) and maxNameStr (str, _) = case str of @@ -991,10 +1005,11 @@ and maxNameSgi (sgi, _) = | SgiStr (_, n, sgn) => Int.max (n, maxNameSgn sgn) | SgiSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn) | SgiConstraint _ => 0 - | SgiTable (n, _, _, _) => n - | SgiSequence (n, _, _) => n + | SgiTable (n1, _, n2, _) => Int.max (n1, n2) + | SgiSequence (n1, _, n2) => Int.max (n1, n2) | SgiClassAbs (_, n) => n | SgiClass (_, n, _) => n + | SgiCookie (n1, _, n2, _) => Int.max (n1, n2) end diff --git a/src/elaborate.sml b/src/elaborate.sml index b0f2d331..3a966eaf 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1760,6 +1760,7 @@ val hnormSgn = E.hnormSgn fun tableOf () = (L'.CModProj (!basis_r, [], "sql_table"), ErrorMsg.dummySpan) fun sequenceOf () = (L'.CModProj (!basis_r, [], "sql_sequence"), ErrorMsg.dummySpan) +fun cookieOf () = (L'.CModProj (!basis_r, [], "http_cookie"), ErrorMsg.dummySpan) fun elabSgn_item ((sgi, loc), (env, denv, gs)) = case sgi of @@ -1967,6 +1968,15 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = ([(L'.SgiClass (x, n, c'), loc)], (env, denv, [])) end + | L.SgiCookie (x, c) => + let + val (c', k, gs) = elabCon (env, denv) c + val (env, n) = E.pushENamed env x (L'.CApp (cookieOf (), c'), loc) + in + checkKind env c' k (L'.KType, loc); + ([(L'.SgiCookie (!basis_r, x, n, c'), loc)], (env, denv, gs)) + end + and elabSgn (env, denv) (sgn, loc) = case sgn of L.SgnConst sgis => @@ -2051,7 +2061,13 @@ and elabSgn (env, denv) (sgn, loc) = sgnError env (DuplicateCon (loc, x)) else (); - (SS.add (cons, x), vals, sgns, strs))) + (SS.add (cons, x), vals, sgns, strs)) + | L'.SgiCookie (_, x, _, _) => + (if SS.member (vals, x) then + sgnError env (DuplicateVal (loc, x)) + else + (); + (cons, SS.add (vals, x), sgns, strs))) (SS.empty, SS.empty, SS.empty, SS.empty) sgis' in ((L'.SgnConst sgis', loc), gs) @@ -2203,6 +2219,9 @@ fun dopen (env, denv) {str, strs, sgn} = in (L'.DCon (x, n, k, c), loc) end + | L'.SgiCookie (_, x, n, c) => + (L'.DVal (x, n, (L'.CApp (cookieOf (), c), loc), + (L'.EModProj (str, strs, x), loc)), loc) in (d, (E.declBinds env' d, denv')) end) @@ -2259,6 +2278,7 @@ fun sgiOfDecl (d, loc) = | L'.DSequence (tn, x, n) => [(L'.SgiSequence (tn, x, n), loc)] | L'.DClass (x, n, c) => [(L'.SgiClass (x, n, c), loc)] | L'.DDatabase _ => [] + | L'.DCookie (tn, x, n, c) => [(L'.SgiCookie (tn, x, n, c), loc)] fun sgiBindsD (env, denv) (sgi, _) = case sgi of @@ -2508,6 +2528,16 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = SOME (env, denv)) else NONE + | L'.SgiCookie (_, x', n1, c1) => + if x = x' then + (case unifyCons (env, denv) (L'.CApp (cookieOf (), c1), loc) c2 of + [] => SOME (env, denv) + | _ => NONE) + handle CUnify (c1, c2, err) => + (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)); + SOME (env, denv)) + else + NONE | _ => NONE) | L'.SgiStr (x, n2, sgn2) => @@ -2651,6 +2681,21 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = L'.SgiClass (x', n1, c1) => found (x', n1, c1) | _ => NONE end) + + | L'.SgiCookie (_, x, n2, c2) => + seek (fn sgi1All as (sgi1, _) => + case sgi1 of + L'.SgiCookie (_, x', n1, c1) => + if x = x' then + (case unifyCons (env, denv) c1 c2 of + [] => SOME (env, denv) + | _ => NONE) + handle CUnify (c1, c2, err) => + (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)); + SOME (env, denv)) + else + NONE + | _ => NONE) end in ignore (foldl folder (env, denv) sgis2) @@ -3194,6 +3239,15 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = | L.DDatabase s => ([(L'.DDatabase s, loc)], (env, denv, gs)) + | L.DCookie (x, c) => + let + val (c', k, gs') = elabCon (env, denv) c + val (env, n) = E.pushENamed env x (L'.CApp (cookieOf (), c'), loc) + in + checkKind env c' k (L'.KType, loc); + ([(L'.DCookie (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs)) + end + (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) in (*prefaces "elabDecl" [("e", SourcePrint.p_decl dAll), @@ -3336,6 +3390,16 @@ and elabStr (env, denv) (str, loc) = (SS.add (cons, x), x) in ((L'.SgiClass (x, n, c), loc) :: sgis, cons, vals, sgns, strs) + end + | L'.SgiCookie (tn, x, n, c) => + let + val (vals, x) = + if SS.member (vals, x) then + (vals, "?" ^ x) + else + (SS.add (vals, x), x) + in + ((L'.SgiCookie (tn, x, n, c), loc) :: sgis, cons, vals, sgns, strs) end) ([], SS.empty, SS.empty, SS.empty, SS.empty) sgis diff --git a/src/elisp/urweb-defs.el b/src/elisp/urweb-defs.el index fe4da2e4..5551b7a2 100644 --- a/src/elisp/urweb-defs.el +++ b/src/elisp/urweb-defs.el @@ -108,7 +108,7 @@ notion of \"the end of an outline\".") "datatype" "type" "open" "include" urweb-module-head-syms "con" "fold" "where" "extern" "constraint" "constraints" - "table" "sequence" "class") + "table" "sequence" "class" "cookie") "Symbols starting an sexp.") ;; (defconst urweb-not-arg-start-re @@ -134,7 +134,7 @@ notion of \"the end of an outline\".") (,urweb-=-starter-syms nil) (("case" "datatype" "if" "then" "else" "let" "open" "sig" "struct" "type" "val" - "con" "constraint" "table" "sequence" "class"))))) + "con" "constraint" "table" "sequence" "class" "cookie"))))) (defconst urweb-starters-indent-after (urweb-syms-re "let" "in" "struct" "sig") @@ -188,7 +188,7 @@ for all symbols and in all lines starting with the given symbol." (append urweb-module-head-syms '("datatype" "fun" "open" "type" "val" "and" - "con" "constraint" "table" "sequence" "class")) + "con" "constraint" "table" "sequence" "class" "cookie")) "The starters of new expressions.") (defconst urweb-exptrail-syms diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index 1a578cf9..223006fc 100644 --- a/src/elisp/urweb-mode.el +++ b/src/elisp/urweb-mode.el @@ -136,7 +136,7 @@ See doc for the variable `urweb-mode-info'." "datatype" "else" "end" "extern" "fn" "fold" "fun" "functor" "if" "include" "of" "open" "let" "in" - "rec" "sequence" "sig" "signature" + "rec" "sequence" "sig" "signature" "cookie" "struct" "structure" "table" "then" "type" "val" "where" "with" @@ -223,7 +223,7 @@ See doc for the variable `urweb-mode-info'." ("\\<\\(\\(data\\)?type\\|con\\|class\\)\\s-+\\(\\sw+\\)" (1 font-lock-keyword-face) (3 (amAttribute font-lock-type-def-face))) - ("\\<\\(val\\|table\\|sequence\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]" + ("\\<\\(val\\|table\\|sequence\\|cookie\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]" (1 font-lock-keyword-face) (3 (amAttribute font-lock-variable-name-face))) ("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)" diff --git a/src/source.sml b/src/source.sml index 7e204390..a0591afb 100644 --- a/src/source.sml +++ b/src/source.sml @@ -85,6 +85,7 @@ datatype sgn_item' = | SgiSequence of string | SgiClassAbs of string | SgiClass of string * con + | SgiCookie of string * con and sgn' = SgnConst of sgn_item list @@ -157,6 +158,7 @@ datatype decl' = | DSequence of string | DClass of string * con | DDatabase of string + | DCookie of string * con and str' = StrConst of decl list diff --git a/src/source_print.sml b/src/source_print.sml index 9e6608df..d33fb38d 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -428,6 +428,13 @@ fun p_sgn_item (sgi, _) = string "=", space, p_con c] + | SgiCookie (x, c) => box [string "cookie", + space, + string x, + space, + string ":", + space, + p_con c] and p_sgn (sgn, _) = case sgn of @@ -579,6 +586,14 @@ fun p_decl ((d, _) : decl) = space, string s] + | DCookie (x, c) => box [string "cookie", + space, + string x, + space, + string ":", + space, + p_con c] + and p_str (str, _) = case str of StrConst ds => box [string "struct", diff --git a/src/unnest.sml b/src/unnest.sml index b56daf8a..6a37d484 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -348,6 +348,7 @@ fun unnest file = | DSequence _ => default () | DClass _ => default () | DDatabase _ => default () + | DCookie _ => default () end and doStr (all as (str, loc), st) = diff --git a/src/urweb.grm b/src/urweb.grm index 1555dc37..879afb9c 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -201,6 +201,7 @@ fun tagIn bt = | LET | IN | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE + | COOKIE | CASE | IF | THEN | ELSE | XML_BEGIN of string | XML_END | XML_BEGIN_END of string @@ -426,6 +427,7 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let in [(DClass (SYMBOL1, c), s (CLASSleft, cexpright))] end) + | COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))]) kopt : (NONE) | DCOLON kind (SOME kind) @@ -506,6 +508,7 @@ sgi : CON SYMBOL DCOLON kind (SgiConAbs (SYMBOL, kind), s (CONleft, k in (SgiClass (SYMBOL1, c), s (CLASSleft, cexpright)) end) + | COOKIE SYMBOL COLON cexp (SgiCookie (SYMBOL, cexp), s (COOKIEleft, cexpright)) sgis : ([]) | sgi sgis (sgi :: sgis) diff --git a/src/urweb.lex b/src/urweb.lex index d5393e7d..f5ea558a 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -313,6 +313,7 @@ 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)); + "cookie" => (Tokens.COOKIE (pos yypos, pos yypos + size yytext)); "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext)); "Name" => (Tokens.NAME (pos yypos, pos yypos + size yytext)); diff --git a/tests/cookie.ur b/tests/cookie.ur new file mode 100644 index 00000000..b2bca580 --- /dev/null +++ b/tests/cookie.ur @@ -0,0 +1,9 @@ +cookie c : string + +fun main () : transaction page = + setCookie c "Hi"; + so <- getCookie c; + case so of + None => return No cookie + | Some s => return Cookie: {[s]} + diff --git a/tests/cookie.urp b/tests/cookie.urp new file mode 100644 index 00000000..61a1a1e0 --- /dev/null +++ b/tests/cookie.urp @@ -0,0 +1,3 @@ +debug + +cookie -- cgit v1.2.3 From ea5a24773259c147e806960843d3305a3c72067b Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 10:43:48 -0500 Subject: Cookies through explify --- src/elab.sml | 3 - src/elab_env.sml | 27 --------- src/elab_print.sml | 17 ------ src/elab_util.sml | 17 +----- src/elaborate.sml | 160 ++------------------------------------------------- src/expl.sml | 3 +- src/expl_env.sml | 19 ++---- src/expl_print.sml | 17 +++--- src/expl_util.sml | 9 +-- src/explify.sml | 3 +- src/source.sml | 3 - src/source_print.sml | 17 ------ src/urweb.grm | 23 +++++++- 13 files changed, 41 insertions(+), 277 deletions(-) diff --git a/src/elab.sml b/src/elab.sml index afb8f7aa..d00d1f1a 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -135,11 +135,8 @@ datatype sgn_item' = | SgiStr of string * int * sgn | SgiSgn of string * int * sgn | SgiConstraint of con * con - | SgiTable of int * string * int * con - | SgiSequence of int * string * int | SgiClassAbs of string * int | SgiClass of string * int * con - | SgiCookie of int * string * int * con and sgn' = SgnConst of sgn_item list diff --git a/src/elab_env.sml b/src/elab_env.sml index a782771a..b14cd06c 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -588,11 +588,8 @@ fun sgiSeek (sgi, (sgns, strs, cons)) = | SgiSgn (x, n, _) => (IM.insert (sgns, n, x), strs, cons) | SgiStr (x, n, _) => (sgns, IM.insert (strs, n, x), cons) | SgiConstraint _ => (sgns, strs, cons) - | SgiTable _ => (sgns, strs, cons) - | SgiSequence _ => (sgns, strs, cons) | SgiClassAbs (x, n) => (sgns, strs, IM.insert (cons, n, x)) | SgiClass (x, n, _) => (sgns, strs, IM.insert (cons, n, x)) - | SgiCookie _ => (sgns, strs, cons) fun sgnSeek f sgis = let @@ -931,30 +928,9 @@ fun sgiBinds env (sgi, loc) = | SgiSgn (x, n, sgn) => pushSgnNamedAs env x n sgn | SgiConstraint _ => env - | SgiTable (tn, x, n, c) => - let - val t = (CApp ((CModProj (tn, [], "sql_table"), loc), c), loc) - in - pushENamedAs env x n t - end - | SgiSequence (tn, x, n) => - let - val t = (CModProj (tn, [], "sql_sequence"), loc) - in - pushENamedAs env x n t - end - | SgiClassAbs (x, n) => pushCNamedAs env x n (KArrow ((KType, loc), (KType, loc)), loc) NONE | SgiClass (x, n, c) => pushCNamedAs env x n (KArrow ((KType, loc), (KType, loc)), loc) (SOME c) - | SgiCookie (tn, x, n, c) => - let - val t = (CApp ((CModProj (tn, [], "http_cookie"), loc), c), loc) - in - pushENamedAs env x n t - end - - fun sgnSubCon x = ElabUtil.Con.map {kind = id, con = sgnS_con x} @@ -1099,11 +1075,8 @@ fun sgnSeekConstraints (str, sgis) = | SgiVal _ => seek (sgis, sgns, strs, cons, acc) | SgiSgn (x, n, _) => seek (sgis, IM.insert (sgns, n, x), strs, cons, acc) | SgiStr (x, n, _) => seek (sgis, sgns, IM.insert (strs, n, x), cons, acc) - | SgiTable _ => seek (sgis, sgns, strs, cons, acc) - | SgiSequence _ => seek (sgis, sgns, strs, cons, acc) | SgiClassAbs (x, n) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) | SgiClass (x, n, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) - | SgiCookie _ => seek (sgis, sgns, strs, cons, acc) in seek (sgis, IM.empty, IM.empty, IM.empty, []) end diff --git a/src/elab_print.sml b/src/elab_print.sml index a686abe5..2afedef1 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -516,16 +516,6 @@ fun p_sgn_item env (sgi, _) = string "~", space, p_con env c2] - | SgiTable (_, x, n, c) => box [string "table", - space, - p_named x n, - space, - string ":", - space, - p_con env c] - | SgiSequence (_, x, n) => box [string "sequence", - space, - p_named x n] | SgiClassAbs (x, n) => box [string "class", space, p_named x n] @@ -536,13 +526,6 @@ fun p_sgn_item env (sgi, _) = string "=", space, p_con env c] - | SgiCookie (_, x, n, c) => box [string "cookie", - space, - p_named x n, - space, - string ":", - space, - p_con env c] and p_sgn env (sgn, _) = case sgn of diff --git a/src/elab_util.sml b/src/elab_util.sml index fe75ee0d..9c25ae86 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -538,20 +538,11 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = S.map2 (con ctx c2, fn c2' => (SgiConstraint (c1', c2'), loc))) - | SgiTable (tn, x, n, c) => - S.map2 (con ctx c, - fn c' => - (SgiTable (tn, x, n, c'), loc)) - | SgiSequence _ => S.return2 siAll | SgiClassAbs _ => S.return2 siAll | SgiClass (x, n, c) => S.map2 (con ctx c, fn c' => (SgiClass (x, n, c'), loc)) - | SgiCookie (tn, x, n, c) => - S.map2 (con ctx c, - fn c' => - (SgiCookie (tn, x, n, c'), loc)) and sg ctx s acc = S.bindP (sg' ctx s acc, sgn ctx) @@ -575,13 +566,10 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = | SgiSgn (x, _, sgn) => bind (ctx, Sgn (x, sgn)) | SgiConstraint _ => ctx - | SgiTable _ => ctx - | SgiSequence _ => ctx | SgiClassAbs (x, n) => bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))) | SgiClass (x, n, _) => - bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))) - | SgiCookie _ => ctx, + bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))), sgi ctx si)) ctx sgis, fn sgis' => (SgnConst sgis', loc)) @@ -1005,11 +993,8 @@ and maxNameSgi (sgi, _) = | SgiStr (_, n, sgn) => Int.max (n, maxNameSgn sgn) | SgiSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn) | SgiConstraint _ => 0 - | SgiTable (n1, _, n2, _) => Int.max (n1, n2) - | SgiSequence (n1, _, n2) => Int.max (n1, n2) | SgiClassAbs (_, n) => n | SgiClass (_, n, _) => n - | SgiCookie (n1, _, n2, _) => Int.max (n1, n2) end diff --git a/src/elaborate.sml b/src/elaborate.sml index 3a966eaf..3b70c623 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1932,22 +1932,6 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = ([(L'.SgiConstraint (c1', c2'), loc)], (env, denv, gs1 @ gs2 @ gs3)) end - | L.SgiTable (x, c) => - let - val (c', k, gs) = elabCon (env, denv) c - val (env, n) = E.pushENamed env x (L'.CApp (tableOf (), c'), loc) - in - checkKind env c' k (L'.KRecord (L'.KType, loc), loc); - ([(L'.SgiTable (!basis_r, x, n, c'), loc)], (env, denv, gs)) - end - - | L.SgiSequence x => - let - val (env, n) = E.pushENamed env x (sequenceOf ()) - in - ([(L'.SgiSequence (!basis_r, x, n), loc)], (env, denv, gs)) - end - | L.SgiClassAbs x => let val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) @@ -1968,15 +1952,6 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = ([(L'.SgiClass (x, n, c'), loc)], (env, denv, [])) end - | L.SgiCookie (x, c) => - let - val (c', k, gs) = elabCon (env, denv) c - val (env, n) = E.pushENamed env x (L'.CApp (cookieOf (), c'), loc) - in - checkKind env c' k (L'.KType, loc); - ([(L'.SgiCookie (!basis_r, x, n, c'), loc)], (env, denv, gs)) - end - and elabSgn (env, denv) (sgn, loc) = case sgn of L.SgnConst sgis => @@ -2038,18 +2013,6 @@ and elabSgn (env, denv) (sgn, loc) = (); (cons, vals, sgns, SS.add (strs, x))) | L'.SgiConstraint _ => (cons, vals, sgns, strs) - | L'.SgiTable (_, x, _, _) => - (if SS.member (vals, x) then - sgnError env (DuplicateVal (loc, x)) - else - (); - (cons, SS.add (vals, x), sgns, strs)) - | L'.SgiSequence (_, x, _) => - (if SS.member (vals, x) then - sgnError env (DuplicateVal (loc, x)) - else - (); - (cons, SS.add (vals, x), sgns, strs)) | L'.SgiClassAbs (x, _) => (if SS.member (cons, x) then sgnError env (DuplicateCon (loc, x)) @@ -2061,13 +2024,7 @@ and elabSgn (env, denv) (sgn, loc) = sgnError env (DuplicateCon (loc, x)) else (); - (SS.add (cons, x), vals, sgns, strs)) - | L'.SgiCookie (_, x, _, _) => - (if SS.member (vals, x) then - sgnError env (DuplicateVal (loc, x)) - else - (); - (cons, SS.add (vals, x), sgns, strs))) + (SS.add (cons, x), vals, sgns, strs))) (SS.empty, SS.empty, SS.empty, SS.empty) sgis' in ((L'.SgnConst sgis', loc), gs) @@ -2199,12 +2156,6 @@ fun dopen (env, denv) {str, strs, sgn} = (L'.DSgn (x, n, (L'.SgnProj (str, strs, x), loc)), loc) | L'.SgiConstraint (c1, c2) => (L'.DConstraint (c1, c2), loc) - | L'.SgiTable (_, x, n, c) => - (L'.DVal (x, n, (L'.CApp (tableOf (), c), loc), - (L'.EModProj (str, strs, x), loc)), loc) - | L'.SgiSequence (_, x, n) => - (L'.DVal (x, n, sequenceOf (), - (L'.EModProj (str, strs, x), loc)), loc) | L'.SgiClassAbs (x, n) => let val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) @@ -2219,9 +2170,6 @@ fun dopen (env, denv) {str, strs, sgn} = in (L'.DCon (x, n, k, c), loc) end - | L'.SgiCookie (_, x, n, c) => - (L'.DVal (x, n, (L'.CApp (cookieOf (), c), loc), - (L'.EModProj (str, strs, x), loc)), loc) in (d, (E.declBinds env' d, denv')) end) @@ -2274,11 +2222,11 @@ fun sgiOfDecl (d, loc) = | L'.DFfiStr (x, n, sgn) => [(L'.SgiStr (x, n, sgn), loc)] | L'.DConstraint cs => [(L'.SgiConstraint cs, loc)] | L'.DExport _ => [] - | L'.DTable (tn, x, n, c) => [(L'.SgiTable (tn, x, n, c), loc)] - | L'.DSequence (tn, x, n) => [(L'.SgiSequence (tn, x, n), loc)] + | L'.DTable (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (tableOf (), c), loc)), loc)] + | L'.DSequence (tn, x, n) => [(L'.SgiVal (x, n, sequenceOf ()), loc)] | L'.DClass (x, n, c) => [(L'.SgiClass (x, n, c), loc)] | L'.DDatabase _ => [] - | L'.DCookie (tn, x, n, c) => [(L'.SgiCookie (tn, x, n, c), loc)] + | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] fun sgiBindsD (env, denv) (sgi, _) = case sgi of @@ -2508,36 +2456,6 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = SOME (env, denv)) else NONE - | L'.SgiTable (_, x', n1, c1) => - if x = x' then - (case unifyCons (env, denv) (L'.CApp (tableOf (), c1), loc) c2 of - [] => SOME (env, denv) - | _ => NONE) - handle CUnify (c1, c2, err) => - (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)); - SOME (env, denv)) - else - NONE - | L'.SgiSequence (_, x', n1) => - if x = x' then - (case unifyCons (env, denv) (sequenceOf ()) c2 of - [] => SOME (env, denv) - | _ => NONE) - handle CUnify (c1, c2, err) => - (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)); - SOME (env, denv)) - else - NONE - | L'.SgiCookie (_, x', n1, c1) => - if x = x' then - (case unifyCons (env, denv) (L'.CApp (cookieOf (), c1), loc) c2 of - [] => SOME (env, denv) - | _ => NONE) - handle CUnify (c1, c2, err) => - (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)); - SOME (env, denv)) - else - NONE | _ => NONE) | L'.SgiStr (x, n2, sgn2) => @@ -2600,31 +2518,6 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = NONE | _ => NONE) - | L'.SgiTable (_, x, n2, c2) => - seek (fn sgi1All as (sgi1, _) => - case sgi1 of - L'.SgiTable (_, x', n1, c1) => - if x = x' then - (case unifyCons (env, denv) c1 c2 of - [] => SOME (env, denv) - | _ => NONE) - handle CUnify (c1, c2, err) => - (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)); - SOME (env, denv)) - else - NONE - | _ => NONE) - - | L'.SgiSequence (_, x, n2) => - seek (fn sgi1All as (sgi1, _) => - case sgi1 of - L'.SgiSequence (_, x', n1) => - if x = x' then - SOME (env, denv) - else - NONE - | _ => NONE) - | L'.SgiClassAbs (x, n2) => seek (fn sgi1All as (sgi1, _) => let @@ -2681,21 +2574,6 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = L'.SgiClass (x', n1, c1) => found (x', n1, c1) | _ => NONE end) - - | L'.SgiCookie (_, x, n2, c2) => - seek (fn sgi1All as (sgi1, _) => - case sgi1 of - L'.SgiCookie (_, x', n1, c1) => - if x = x' then - (case unifyCons (env, denv) c1 c2 of - [] => SOME (env, denv) - | _ => NONE) - handle CUnify (c1, c2, err) => - (sgnError env (SgiWrongCon (sgi1All, c1, sgi2All, c2, err)); - SOME (env, denv)) - else - NONE - | _ => NONE) end in ignore (foldl folder (env, denv) sgis2) @@ -3347,26 +3225,6 @@ and elabStr (env, denv) (str, loc) = ((L'.SgiStr (x, n, sgn), loc) :: sgis, cons, vals, sgns, strs) end | L'.SgiConstraint _ => ((sgi, loc) :: sgis, cons, vals, sgns, strs) - | L'.SgiTable (tn, x, n, c) => - let - val (vals, x) = - if SS.member (vals, x) then - (vals, "?" ^ x) - else - (SS.add (vals, x), x) - in - ((L'.SgiTable (tn, x, n, c), loc) :: sgis, cons, vals, sgns, strs) - end - | L'.SgiSequence (tn, x, n) => - let - val (vals, x) = - if SS.member (vals, x) then - (vals, "?" ^ x) - else - (SS.add (vals, x), x) - in - ((L'.SgiSequence (tn, x, n), loc) :: sgis, cons, vals, sgns, strs) - end | L'.SgiClassAbs (x, n) => let val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) @@ -3390,16 +3248,6 @@ and elabStr (env, denv) (str, loc) = (SS.add (cons, x), x) in ((L'.SgiClass (x, n, c), loc) :: sgis, cons, vals, sgns, strs) - end - | L'.SgiCookie (tn, x, n, c) => - let - val (vals, x) = - if SS.member (vals, x) then - (vals, "?" ^ x) - else - (SS.add (vals, x), x) - in - ((L'.SgiCookie (tn, x, n, c), loc) :: sgis, cons, vals, sgns, strs) end) ([], SS.empty, SS.empty, SS.empty, SS.empty) sgis diff --git a/src/expl.sml b/src/expl.sml index 8f531516..57396684 100644 --- a/src/expl.sml +++ b/src/expl.sml @@ -110,8 +110,6 @@ datatype sgn_item' = | SgiVal of string * int * con | SgiSgn of string * int * sgn | SgiStr of string * int * sgn - | SgiTable of int * string * int * con - | SgiSequence of int * string * int and sgn' = SgnConst of sgn_item list @@ -136,6 +134,7 @@ datatype decl' = | DTable of int * string * int * con | DSequence of int * string * int | DDatabase of string + | DCookie of int * string * int * con and str' = StrConst of decl list diff --git a/src/expl_env.sml b/src/expl_env.sml index 43456c41..0fefec2d 100644 --- a/src/expl_env.sml +++ b/src/expl_env.sml @@ -295,6 +295,12 @@ fun declBinds env (d, loc) = pushENamed env x n t end | DDatabase _ => env + | DCookie (tn, x, n, c) => + let + val t = (CApp ((CModProj (tn, [], "http_cookie"), loc), c), loc) + in + pushENamed env x n t + end fun sgiBinds env (sgi, loc) = case sgi of @@ -341,17 +347,4 @@ fun sgiBinds env (sgi, loc) = | SgiSgn (x, n, sgn) => pushSgnNamed env x n sgn | SgiStr (x, n, sgn) => pushStrNamed env x n sgn - | SgiTable (tn, x, n, c) => - let - val t = (CApp ((CModProj (tn, [], "sql_table"), loc), c), loc) - in - pushENamed env x n t - end - | SgiSequence (tn, x, n) => - let - val t = (CModProj (tn, [], "sql_sequence"), loc) - in - pushENamed env x n t - end - end diff --git a/src/expl_print.sml b/src/expl_print.sml index aecc3a84..2d41ab34 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -471,16 +471,6 @@ fun p_sgn_item env (sgi, _) = string "=", space, p_sgn env sgn] - | SgiTable (_, x, n, c) => box [string "table", - space, - p_named x n, - space, - string ":", - space, - p_con env c] - | SgiSequence (_, x, n) => box [string "sequence", - space, - p_named x n] and p_sgn env (sgn, loc) = case sgn of @@ -635,6 +625,13 @@ fun p_decl env (dAll as (d, _) : decl) = | DDatabase s => box [string "database", space, string s] + | DCookie (_, x, n, c) => box [string "cookie", + space, + p_named x n, + space, + string ":", + space, + p_con env c] and p_str env (str, _) = case str of diff --git a/src/expl_util.sml b/src/expl_util.sml index 337ea8d6..2bd9eabd 100644 --- a/src/expl_util.sml +++ b/src/expl_util.sml @@ -432,11 +432,6 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = S.map2 (sg ctx s, fn s' => (SgiSgn (x, n, s'), loc)) - | SgiTable (tn, x, n, c) => - S.map2 (con ctx c, - fn c' => - (SgiTable (tn, x, n, c'), loc)) - | SgiSequence _ => S.return2 siAll and sg ctx s acc = S.bindP (sg' ctx s acc, sgn ctx) @@ -458,9 +453,7 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = | SgiStr (x, _, sgn) => bind (ctx, Str (x, sgn)) | SgiSgn (x, _, sgn) => - bind (ctx, Sgn (x, sgn)) - | SgiTable _ => ctx - | SgiSequence _ => ctx, + bind (ctx, Sgn (x, sgn)), sgi ctx si)) ctx sgis, fn sgis' => (SgnConst sgis', loc)) diff --git a/src/explify.sml b/src/explify.sml index e19bb200..4115476b 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -137,8 +137,6 @@ fun explifySgi (sgi, loc) = | L.SgiStr (x, n, sgn) => SOME (L'.SgiStr (x, n, explifySgn sgn), loc) | L.SgiSgn (x, n, sgn) => SOME (L'.SgiSgn (x, n, explifySgn sgn), loc) | L.SgiConstraint _ => NONE - | L.SgiTable (nt, x, n, c) => SOME (L'.SgiTable (nt, x, n, explifyCon c), loc) - | L.SgiSequence (nt, x, n) => SOME (L'.SgiSequence (nt, x, n), loc) | L.SgiClassAbs (x, n) => SOME (L'.SgiConAbs (x, n, (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc)), loc) | L.SgiClass (x, n, c) => SOME (L'.SgiCon (x, n, (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc), explifyCon c), loc) @@ -175,6 +173,7 @@ fun explifyDecl (d, loc : EM.span) = | L.DClass (x, n, c) => SOME (L'.DCon (x, n, (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc), explifyCon c), loc) | L.DDatabase s => SOME (L'.DDatabase s, loc) + | L.DCookie (nt, x, n, c) => SOME (L'.DCookie (nt, x, n, explifyCon c), loc) and explifyStr (str, loc) = case str of diff --git a/src/source.sml b/src/source.sml index a0591afb..2a348338 100644 --- a/src/source.sml +++ b/src/source.sml @@ -81,11 +81,8 @@ datatype sgn_item' = | SgiSgn of string * sgn | SgiInclude of sgn | SgiConstraint of con * con - | SgiTable of string * con - | SgiSequence of string | SgiClassAbs of string | SgiClass of string * con - | SgiCookie of string * con and sgn' = SgnConst of sgn_item list diff --git a/src/source_print.sml b/src/source_print.sml index d33fb38d..3c26812f 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -408,16 +408,6 @@ fun p_sgn_item (sgi, _) = string "~", space, p_con c2] - | SgiTable (x, c) => box [string "table", - space, - string x, - space, - string ":", - space, - p_con c] - | SgiSequence x => box [string "sequence", - space, - string x] | SgiClassAbs x => box [string "class", space, string x] @@ -428,13 +418,6 @@ fun p_sgn_item (sgi, _) = string "=", space, p_con c] - | SgiCookie (x, c) => box [string "cookie", - space, - string x, - space, - string ":", - space, - p_con c] and p_sgn (sgn, _) = case sgn of diff --git a/src/urweb.grm b/src/urweb.grm index 879afb9c..b2f2d486 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -497,8 +497,19 @@ sgi : CON SYMBOL DCOLON kind (SgiConAbs (SYMBOL, kind), s (CONleft, k s (FUNCTORleft, sgn2right)) | INCLUDE sgn (SgiInclude sgn, s (INCLUDEleft, sgnright)) | CONSTRAINT cterm TWIDDLE cterm (SgiConstraint (cterm1, cterm2), s (CONSTRAINTleft, ctermright)) - | TABLE SYMBOL COLON cexp (SgiTable (SYMBOL, entable cexp), s (TABLEleft, cexpright)) - | SEQUENCE SYMBOL (SgiSequence SYMBOL, s (SEQUENCEleft, SYMBOLright)) + | TABLE SYMBOL COLON cexp (let + val loc = s (TABLEleft, cexpright) + val t = (CApp ((CVar (["Basis"], "sql_table"), loc), + entable cexp), loc) + in + (SgiVal (SYMBOL, t), loc) + end) + | SEQUENCE SYMBOL (let + val loc = s (SEQUENCEleft, SYMBOLright) + val t = (CVar (["Basis"], "sql_sequence"), loc) + in + (SgiVal (SYMBOL, t), loc) + end) | CLASS SYMBOL (SgiClassAbs SYMBOL, s (CLASSleft, SYMBOLright)) | CLASS SYMBOL EQ cexp (SgiClass (SYMBOL, cexp), s (CLASSleft, cexpright)) | CLASS SYMBOL SYMBOL EQ cexp (let @@ -508,7 +519,13 @@ sgi : CON SYMBOL DCOLON kind (SgiConAbs (SYMBOL, kind), s (CONleft, k in (SgiClass (SYMBOL1, c), s (CLASSleft, cexpright)) end) - | COOKIE SYMBOL COLON cexp (SgiCookie (SYMBOL, cexp), s (COOKIEleft, cexpright)) + | COOKIE SYMBOL COLON cexp (let + val loc = s (COOKIEleft, cexpright) + val t = (CApp ((CVar (["Basis"], "http_cookie"), loc), + entable cexp), loc) + in + (SgiVal (SYMBOL, t), loc) + end) sgis : ([]) | sgi sgis (sgi :: sgis) -- cgit v1.2.3 From 59e90f80efd94c738df349da7d473da9a8a7e81a Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 10:48:02 -0500 Subject: Cookies through shake2 --- src/core.sml | 1 + src/core_env.sml | 6 ++++++ src/core_print.sml | 11 +++++++++++ src/core_util.sml | 17 ++++++++++++++--- src/corify.sml | 11 ++++++++++- src/shake.sml | 7 +++++-- 6 files changed, 47 insertions(+), 6 deletions(-) diff --git a/src/core.sml b/src/core.sml index 0b81e50e..1a181a68 100644 --- a/src/core.sml +++ b/src/core.sml @@ -120,6 +120,7 @@ datatype decl' = | DTable of string * int * con * string | DSequence of string * int * string | DDatabase of string + | DCookie of string * int * con * string withtype decl = decl' located diff --git a/src/core_env.sml b/src/core_env.sml index 0faf5aab..07162606 100644 --- a/src/core_env.sml +++ b/src/core_env.sml @@ -257,6 +257,12 @@ fun declBinds env (d, loc) = pushENamed env x n t NONE s end | DDatabase _ => env + | DCookie (x, n, c, s) => + let + val t = (CApp ((CFfi ("Basis", "http_cookie"), loc), c), loc) + in + pushENamed env x n t NONE s + end fun patBinds env (p, loc) = case p of diff --git a/src/core_print.sml b/src/core_print.sml index cd31487e..7de31568 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -504,6 +504,17 @@ fun p_decl env (dAll as (d, _) : decl) = | DDatabase s => box [string "database", space, string s] + | DCookie (x, n, c, s) => box [string "cookie", + space, + p_named x n, + space, + string "as", + space, + string s, + space, + string ":", + space, + p_con env c] fun p_file env file = let diff --git a/src/core_util.sml b/src/core_util.sml index 2450562f..7e1440a1 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -656,10 +656,14 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} = | DExport _ => S.return2 dAll | DTable (x, n, c, s) => S.map2 (mfc ctx c, - fn c' => - (DTable (x, n, c', s), loc)) + fn c' => + (DTable (x, n, c', s), loc)) | DSequence _ => S.return2 dAll | DDatabase _ => S.return2 dAll + | DCookie (x, n, c, s) => + S.map2 (mfc ctx c, + fn c' => + (DCookie (x, n, c', s), loc)) and mfvi ctx (x, n, t, e, s) = S.bind2 (mfc ctx t, @@ -755,6 +759,12 @@ fun mapfoldB (all as {bind, ...}) = bind (ctx, NamedE (x, n, t, NONE, s)) end | DDatabase _ => ctx + | DCookie (x, n, c, s) => + let + val t = (CApp ((CFfi ("Basis", "http_cookie"), #2 d'), c), #2 d') + in + bind (ctx, NamedE (x, n, t, NONE, s)) + end in S.map2 (mff ctx' ds', fn ds' => @@ -807,7 +817,8 @@ val maxName = foldl (fn ((d, _) : decl, count) => | DExport _ => count | DTable (_, n, _, _) => Int.max (n, count) | DSequence (_, n, _) => Int.max (n, count) - | DDatabase _ => count) 0 + | DDatabase _ => count + | DCookie (_, n, _, _) => Int.max (n, count)) 0 end diff --git a/src/corify.sml b/src/corify.sml index 8b72f9f8..2b90a8f0 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -981,6 +981,14 @@ fun corifyDecl mods ((d, loc : EM.span), st) = | L.DDatabase s => ([(L'.DDatabase s, loc)], st) + | L.DCookie (_, x, n, c) => + let + val (st, n) = St.bindVal st x n + val s = doRestify (mods, x) + in + ([(L'.DCookie (x, n, corifyCon st c, s), loc)], st) + end + and corifyStr mods ((str, _), st) = case str of L.StrConst ds => @@ -1034,7 +1042,8 @@ fun maxName ds = foldl (fn ((d, _), n) => | L.DExport _ => n | L.DTable (_, _, n', _) => Int.max (n, n') | L.DSequence (_, _, n') => Int.max (n, n') - | L.DDatabase _ => n) + | L.DDatabase _ => n + | L.DCookie (_, _, n', _) => Int.max (n, n')) 0 ds and maxNameStr (str, _) = diff --git a/src/shake.sml b/src/shake.sml index 4ebd1b0b..e062743d 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -68,7 +68,9 @@ fun shake file = (cdef, IM.insert (edef, n, ([], c, dummye))) | ((DSequence (_, n, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], dummyt, dummye))) - | ((DDatabase _, _), acc) => acc) + | ((DDatabase _, _), acc) => acc + | ((DCookie (_, n, c, _), _), (cdef, edef)) => + (cdef, IM.insert (edef, n, ([], c, dummye)))) (IM.empty, IM.empty) file fun kind (_, s) = s @@ -136,7 +138,8 @@ fun shake file = | (DExport _, _) => true | (DTable _, _) => true | (DSequence _, _) => true - | (DDatabase _, _) => true) file + | (DDatabase _, _) => true + | (DCookie _, _) => true) file end end -- 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(-) 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(-) 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 6c3a51281f4140589e1b7dfb01b17b6ee38cb4bc Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 12:22:50 -0500 Subject: Cookie demo code; fix error message display --- demo/cookie.ur | 26 ++++++++++++++++++++++++++ demo/cookie.urp | 2 ++ demo/cookie.urs | 1 + src/c/driver.c | 23 +++++++++++++---------- src/c/urweb.c | 12 +----------- 5 files changed, 43 insertions(+), 21 deletions(-) create mode 100644 demo/cookie.ur create mode 100644 demo/cookie.urp create mode 100644 demo/cookie.urs diff --git a/demo/cookie.ur b/demo/cookie.ur new file mode 100644 index 00000000..02f4cab5 --- /dev/null +++ b/demo/cookie.ur @@ -0,0 +1,26 @@ +cookie c : {A : string, B : float, C : int} + +fun set r = + setCookie c {A = r.A, B = readError r.B, C = readError r.C}; + return Cookie set. + +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 + + diff --git a/demo/cookie.urp b/demo/cookie.urp new file mode 100644 index 00000000..9e283d4b --- /dev/null +++ b/demo/cookie.urp @@ -0,0 +1,2 @@ + +cookie diff --git a/demo/cookie.urs b/demo/cookie.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/demo/cookie.urs @@ -0,0 +1 @@ +val main : unit -> transaction page diff --git a/src/c/driver.c b/src/c/driver.c index 438adb8d..d884c025 100644 --- a/src/c/driver.c +++ b/src/c/driver.c @@ -189,6 +189,7 @@ static void *worker(void *data) { printf("Serving URI %s....\n", path); uw_set_headers(ctx, headers); + uw_write(ctx, ""); while (1) { if (uw_db_begin(ctx)) { @@ -198,8 +199,8 @@ static void *worker(void *data) { else { fk = FATAL; uw_reset(ctx); - uw_write(ctx, "HTTP/1.1 500 Internal Server Error\n\r"); - uw_write(ctx, "Content-type: text/plain\r\n\r\n"); + uw_write_header(ctx, "HTTP/1.1 500 Internal Server Error\n\r"); + uw_write_header(ctx, "Content-type: text/plain\r\n\r\n"); uw_write(ctx, "Error running SQL BEGIN\n"); break; @@ -212,13 +213,15 @@ static void *worker(void *data) { strcpy(path_copy, path); fk = uw_begin(ctx, path_copy); if (fk == SUCCESS) { + uw_write(ctx, ""); + if (uw_db_commit(ctx)) { fk = FATAL; printf("Error running SQL COMMIT\n"); uw_reset(ctx); - uw_write(ctx, "HTTP/1.1 500 Internal Server Error\n\r"); - uw_write(ctx, "Content-type: text/plain\r\n\r\n"); + uw_write_header(ctx, "HTTP/1.1 500 Internal Server Error\n\r"); + uw_write_header(ctx, "Content-type: text/plain\r\n"); uw_write(ctx, "Error running SQL COMMIT\n"); } @@ -232,8 +235,8 @@ static void *worker(void *data) { printf("Fatal error (out of retries): %s\n", uw_error_message(ctx)); uw_reset_keep_error_message(ctx); - uw_write(ctx, "HTTP/1.1 500 Internal Server Error\n\r"); - uw_write(ctx, "Content-type: text/plain\r\n\r\n"); + uw_write_header(ctx, "HTTP/1.1 500 Internal Server Error\n\r"); + uw_write_header(ctx, "Content-type: text/plain\r\n"); uw_write(ctx, "Fatal error (out of retries): "); uw_write(ctx, uw_error_message(ctx)); uw_write(ctx, "\n"); @@ -248,8 +251,8 @@ static void *worker(void *data) { printf("Fatal error: %s\n", uw_error_message(ctx)); uw_reset_keep_error_message(ctx); - uw_write(ctx, "HTTP/1.1 500 Internal Server Error\n\r"); - uw_write(ctx, "Content-type: text/plain\r\n\r\n"); + uw_write_header(ctx, "HTTP/1.1 500 Internal Server Error\r\n"); + uw_write_header(ctx, "Content-type: text/plain\r\n"); uw_write(ctx, "Fatal error: "); uw_write(ctx, uw_error_message(ctx)); uw_write(ctx, "\n"); @@ -261,8 +264,8 @@ static void *worker(void *data) { printf("Unknown uw_handle return code!\n"); uw_reset_keep_request(ctx); - uw_write(ctx, "HTTP/1.1 500 Internal Server Error\n\r"); - uw_write(ctx, "Content-type: text/plain\r\n\r\n"); + uw_write_header(ctx, "HTTP/1.1 500 Internal Server Error\n\r"); + uw_write_header(ctx, "Content-type: text/plain\r\n"); uw_write(ctx, "Unknown uw_handle return code!\n"); try_rollback(ctx); diff --git a/src/c/urweb.c b/src/c/urweb.c index be12c5ea..cc21c558 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -315,17 +315,7 @@ int uw_send(uw_context ctx, int sock) { 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); + return uw_really_send(sock, ctx->page, ctx->page_front - ctx->page); } static void uw_check_headers(uw_context ctx, size_t extra) { -- 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(-) 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(-) 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 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 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 36952b2e49afdb4ba8024eb6372992e4b5d8df7a Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 Nov 2008 17:09:53 -0500 Subject: About to begin optimization of recursive transaction functions --- demo/ref.ur | 2 - demo/tree.ur | 15 ++++ demo/tree.urp | 6 ++ demo/tree.urs | 1 + demo/treeFun.ur | 35 ++++++++++ demo/treeFun.urs | 22 ++++++ lib/basis.urs | 3 + lib/top.ur | 11 +++ lib/top.urs | 8 +++ src/elaborate.sml | 198 ++++++++++++++++++++++++++++++++-------------------- src/especialize.sml | 6 +- 11 files changed, 228 insertions(+), 79 deletions(-) create mode 100644 demo/tree.ur create mode 100644 demo/tree.urp create mode 100644 demo/tree.urs create mode 100644 demo/treeFun.ur create mode 100644 demo/treeFun.urs diff --git a/demo/ref.ur b/demo/ref.ur index 4030b6fa..1e406dd9 100644 --- a/demo/ref.ur +++ b/demo/ref.ur @@ -1,11 +1,9 @@ structure IR = RefFun.Make(struct type t = int - val inj = _ end) structure SR = RefFun.Make(struct type t = string - val inj = _ end) fun main () = diff --git a/demo/tree.ur b/demo/tree.ur new file mode 100644 index 00000000..06a30cf9 --- /dev/null +++ b/demo/tree.ur @@ -0,0 +1,15 @@ +table t : { Id : int, Parent : option int, Nam : string } + +open TreeFun.Make(struct + val tab = t + end) + +fun row r = + #{[r.Id]}: {[r.Nam]} + + +fun main () = + xml <- tree row None; + return + {xml} + diff --git a/demo/tree.urp b/demo/tree.urp new file mode 100644 index 00000000..2270dd06 --- /dev/null +++ b/demo/tree.urp @@ -0,0 +1,6 @@ +debug +database dbname=tree +sql tree.sql + +treeFun +tree diff --git a/demo/tree.urs b/demo/tree.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/demo/tree.urs @@ -0,0 +1 @@ +val main : unit -> transaction page diff --git a/demo/treeFun.ur b/demo/treeFun.ur new file mode 100644 index 00000000..60633695 --- /dev/null +++ b/demo/treeFun.ur @@ -0,0 +1,35 @@ +functor Make(M : sig + type key + con id :: Name + con parent :: Name + con cols :: {Type} + constraint [id] ~ [parent] + constraint [id, parent] ~ cols + + val key_inj : sql_injectable key + val option_key_inj : sql_injectable (option key) + + table tab : [id = key, parent = option key] ++ cols + end) = struct + + open M + + fun tree (f : $([id = key, parent = option key] ++ cols) -> xbody) + (root : option M.key) = + let + fun recurse (root : option key) = + queryX' (SELECT * FROM tab WHERE tab.{parent} = {root}) + (fn r => + children <- recurse (Some r.Tab.id); + return +
  • {f r.Tab}
    • + +
      + {children} +
    +     ) + in + recurse root + end + +end diff --git a/demo/treeFun.urs b/demo/treeFun.urs new file mode 100644 index 00000000..501a0575 --- /dev/null +++ b/demo/treeFun.urs @@ -0,0 +1,22 @@ +functor Make(M : sig + type key + con id :: Name + con parent :: Name + con cols :: {Type} + constraint [id] ~ [parent] + constraint [id, parent] ~ cols + + val key_inj : sql_injectable key + val option_key_inj : sql_injectable (option key) + + table tab : [id = key, parent = option key] ++ cols + end) : sig + + con id = M.id + con parent = M.parent + + val tree : ($([id = M.key, parent = option M.key] ++ M.cols) -> xbody) + -> option M.key + -> transaction xbody + +end diff --git a/lib/basis.urs b/lib/basis.urs index f68bedee..daefe954 100644 --- a/lib/basis.urs +++ b/lib/basis.urs @@ -374,7 +374,10 @@ val h1 : bodyTag [] val h2 : bodyTag [] val h3 : bodyTag [] val h4 : bodyTag [] + val li : bodyTag [] +val ol : bodyTag [] +val ul : bodyTag [] val hr : bodyTag [] diff --git a/lib/top.ur b/lib/top.ur index 347b2a35..abc70e53 100644 --- a/lib/top.ur +++ b/lib/top.ur @@ -202,6 +202,17 @@ fun queryX (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit}) (fn fs acc => return {acc}{f fs}) +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] => + [nm = $fields] ++ acc) [] tables) + -> transaction (xml ctx [] [])) = + query q + (fn fs acc => + r <- f fs; + return {acc}{r}) + + fun oneOrNoRows (tables ::: {{Type}}) (exps ::: {Type}) (q : sql_query tables exps) [tables ~ exps] = query q diff --git a/lib/top.urs b/lib/top.urs index d52ec9d7..6653db07 100644 --- a/lib/top.urs +++ b/lib/top.urs @@ -141,6 +141,14 @@ val queryX : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} -> xml ctx [] []) -> transaction (xml ctx [] []) +val queryX' : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} + -> sql_query tables exps + -> fn [tables ~ exps] => + ($(exps ++ fold (fn nm (fields :: {Type}) acc [[nm] ~ acc] => + [nm = $fields] ++ acc) [] tables) + -> transaction (xml ctx [] [])) + -> transaction (xml ctx [] []) + val oneOrNoRows : tables ::: {{Type}} -> exps ::: {Type} -> sql_query tables exps -> fn [tables ~ exps] => diff --git a/src/elaborate.sml b/src/elaborate.sml index a6edc0ed..f0beecdd 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1777,6 +1777,38 @@ fun tableOf () = (L'.CModProj (!basis_r, [], "sql_table"), ErrorMsg.dummySpan) fun sequenceOf () = (L'.CModProj (!basis_r, [], "sql_sequence"), ErrorMsg.dummySpan) fun cookieOf () = (L'.CModProj (!basis_r, [], "http_cookie"), ErrorMsg.dummySpan) +fun dopenConstraints (loc, env, denv) {str, strs} = + case E.lookupStr env str of + NONE => (strError env (UnboundStr (loc, str)); + denv) + | SOME (n, sgn) => + let + val (st, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {str = str, sgn = sgn, field = m} of + NONE => (strError env (UnboundStr (loc, m)); + (strerror, sgnerror)) + | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) + ((L'.StrVar n, loc), sgn) strs + + val cso = E.projectConstraints env {sgn = sgn, str = st} + + val denv = case cso of + NONE => (strError env (UnboundStr (loc, str)); + denv) + | SOME cs => foldl (fn ((c1, c2), denv) => + let + val (denv, gs) = D.assert env denv (c1, c2) + in + case gs of + [] => () + | _ => raise Fail "dopenConstraints: Sub-constraints remain"; + + denv + end) denv cs + in + denv + end + fun elabSgn_item ((sgi, loc), (env, denv, gs)) = case sgi of L.SgiConAbs (x, k) => @@ -2054,7 +2086,8 @@ and elabSgn (env, denv) (sgn, loc) = let val (dom', gs1) = elabSgn (env, denv) dom val (env', n) = E.pushStrNamed env m dom' - val (ran', gs2) = elabSgn (env', denv) ran + val denv' = dopenConstraints (loc, env', denv) {str = m, strs = []} + val (ran', gs2) = elabSgn (env', denv') ran in ((L'.SgnFun (m, n, dom', ran'), loc), gs1 @ gs2) end @@ -2193,38 +2226,6 @@ fun dopen (env, denv) {str, strs, sgn} = ([], (env, denv))) end -fun dopenConstraints (loc, env, denv) {str, strs} = - case E.lookupStr env str of - NONE => (strError env (UnboundStr (loc, str)); - denv) - | SOME (n, sgn) => - let - val (st, sgn) = foldl (fn (m, (str, sgn)) => - case E.projectStr env {str = str, sgn = sgn, field = m} of - NONE => (strError env (UnboundStr (loc, m)); - (strerror, sgnerror)) - | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) - ((L'.StrVar n, loc), sgn) strs - - val cso = E.projectConstraints env {sgn = sgn, str = st} - - val denv = case cso of - NONE => (strError env (UnboundStr (loc, str)); - denv) - | SOME cs => foldl (fn ((c1, c2), denv) => - let - val (denv, gs) = D.assert env denv (c1, c2) - in - case gs of - [] => () - | _ => raise Fail "dopenConstraints: Sub-constraints remain"; - - denv - end) denv cs - in - denv - end - fun sgiOfDecl (d, loc) = case d of L'.DCon (x, n, k, c) => [(L'.SgiCon (x, n, k, c), loc)] @@ -2252,6 +2253,8 @@ fun sgiBindsD (env, denv) (sgi, _) = | _ => denv fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = + ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), + ("sgn2", p_sgn env sgn2)];*) case (#1 (hnormSgn env sgn1), #1 (hnormSgn env sgn2)) of (L'.SgnError, _) => () | (_, L'.SgnError) => () @@ -2274,8 +2277,18 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = [] => (sgnError env (UnmatchedSgi sgi2All); (env, denv)) | h :: t => - case p h of - NONE => seek (E.sgiBinds env h, sgiBindsD (env, denv) h) t + case p (env, h) of + NONE => + let + val env = case #1 h of + L'.SgiCon (x, n, k, c) => + E.pushCNamedAs env x n k (SOME c) + | L'.SgiConAbs (x, n, k) => + E.pushCNamedAs env x n k NONE + | _ => env + in + seek (E.sgiBinds env h, sgiBindsD (env, denv) h) t + end | SOME envs => envs in seek (env, denv) sgis1 @@ -2283,7 +2296,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = in case sgi of L'.SgiConAbs (x, n2, k2) => - seek (fn sgi1All as (sgi1, _) => + seek (fn (env, sgi1All as (sgi1, _)) => let fun found (x', n1, k1, co1) = if x = x' then @@ -2331,7 +2344,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = end) | L'.SgiCon (x, n2, k2, c2) => - seek (fn sgi1All as (sgi1, _) => + seek (fn (env, sgi1All as (sgi1, _)) => let fun found (x', n1, k1, c1) = if x = x' then @@ -2365,7 +2378,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = end) | L'.SgiDatatype (x, n2, xs2, xncs2) => - seek (fn sgi1All as (sgi1, _) => + seek (fn (env, sgi1All as (sgi1, _)) => let fun found (n1, xs1, xncs1) = let @@ -2426,7 +2439,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = end) | L'.SgiDatatypeImp (x, n2, m12, ms2, s2, xs, _) => - seek (fn sgi1All as (sgi1, _) => + seek (fn (env, sgi1All as (sgi1, _)) => case sgi1 of L'.SgiDatatypeImp (x', n1, m11, ms1, s1, _, _) => if x = x' then @@ -2457,7 +2470,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = | _ => NONE) | L'.SgiVal (x, n2, c2) => - seek (fn sgi1All as (sgi1, _) => + seek (fn (env, sgi1All as (sgi1, _)) => case sgi1 of L'.SgiVal (x', n1, c1) => if x = x' then @@ -2474,7 +2487,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = | _ => NONE) | L'.SgiStr (x, n2, sgn2) => - seek (fn sgi1All as (sgi1, _) => + seek (fn (env, sgi1All as (sgi1, _)) => case sgi1 of L'.SgiStr (x', n1, sgn1) => if x = x' then @@ -2495,7 +2508,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = | _ => NONE) | L'.SgiSgn (x, n2, sgn2) => - seek (fn sgi1All as (sgi1, _) => + seek (fn (env, sgi1All as (sgi1, _)) => case sgi1 of L'.SgiSgn (x', n1, sgn1) => if x = x' then @@ -2516,7 +2529,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = | _ => NONE) | L'.SgiConstraint (c2, d2) => - seek (fn sgi1All as (sgi1, _) => + seek (fn (env, sgi1All as (sgi1, _)) => case sgi1 of L'.SgiConstraint (c1, d1) => if consEq (env, denv) (c1, c2) andalso consEq (env, denv) (d1, d2) then @@ -2534,7 +2547,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = | _ => NONE) | L'.SgiClassAbs (x, n2) => - seek (fn sgi1All as (sgi1, _) => + seek (fn (env, sgi1All as (sgi1, _)) => let fun found (x', n1, co) = if x = x' then @@ -2557,7 +2570,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = | _ => NONE end) | L'.SgiClass (x, n2, c2) => - seek (fn sgi1All as (sgi1, _) => + seek (fn (env, sgi1All as (sgi1, _)) => let val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) @@ -2606,7 +2619,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = subSgn (E.pushStrNamedAs env m2 n2 dom2, denv) ran1 ran2 end - | _ => sgnError env (SgnWrongForm (sgn1, sgn2)) + | _ => sgnError env (SgnWrongForm (sgn1, sgn2))) fun positive self = @@ -2717,46 +2730,79 @@ fun wildifyStr env (str, sgn) = | _ => NONE - val (needed, constraints, _) = - foldl (fn ((sgi, loc), (needed, constraints, env')) => + val (neededC, constraints, neededV, _) = + foldl (fn ((sgi, loc), (neededC, constraints, neededV, env')) => let - val (needed, constraints) = + val (needed, constraints, neededV) = case sgi of - L'.SgiConAbs (x, _, _) => (SS.add (needed, x), constraints) - | L'.SgiConstraint cs => (needed, (env', cs, loc) :: constraints) - | _ => (needed, constraints) + L'.SgiConAbs (x, _, _) => (SS.add (neededC, x), constraints, neededV) + | L'.SgiConstraint cs => (neededC, (env', cs, loc) :: constraints, neededV) + + | L'.SgiVal (x, _, t) => + let + fun default () = (neededC, constraints, neededV) + + val t = normClassConstraint env' t + in + case #1 t of + L'.CApp (f, _) => + if E.isClass env' f then + (neededC, constraints, SS.add (neededV, x)) + else + default () + + | _ => default () + end + + | _ => (neededC, constraints, neededV) in - (needed, constraints, E.sgiBinds env' (sgi, loc)) + (needed, constraints, neededV, E.sgiBinds env' (sgi, loc)) end) - (SS.empty, [], env) sgis + (SS.empty, [], SS.empty, env) sgis - val needed = foldl (fn ((d, _), needed) => - case d of - L.DCon (x, _, _) => (SS.delete (needed, x) - handle NotFound => - needed) - | L.DClass (x, _) => (SS.delete (needed, x) - handle NotFound => needed) - | L.DOpen _ => SS.empty - | _ => needed) - needed ds - - val cds = List.mapPartial (fn (env', (c1, c2), loc) => + val (neededC, neededV) = foldl (fn ((d, _), needed as (neededC, neededV)) => + case d of + L.DCon (x, _, _) => ((SS.delete (neededC, x), neededV) + handle NotFound => + needed) + | L.DClass (x, _) => ((SS.delete (neededC, x), neededV) + handle NotFound => needed) + | L.DVal (x, _, _) => ((neededC, SS.delete (neededV, x)) + handle NotFound => needed) + | L.DOpen _ => (SS.empty, SS.empty) + | _ => needed) + (neededC, neededV) ds + + val ds' = List.mapPartial (fn (env', (c1, c2), loc) => case (decompileCon env' c1, decompileCon env' c2) of (SOME c1, SOME c2) => SOME (L.DConstraint (c1, c2), loc) | _ => NONE) constraints + + val ds' = + case SS.listItems neededV of + [] => ds' + | xs => + let + val ewild = (L.EWild, #2 str) + val ds'' = map (fn x => (L.DVal (x, NONE, ewild), #2 str)) xs + in + ds'' @ ds' + end + + val ds' = + case SS.listItems 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 + in + ds'' @ ds' + end in - case SS.listItems needed of - [] => (L.StrConst (ds @ cds), #2 str) - | 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 - in - (L.StrConst (ds @ ds' @ cds), #2 str) - end + (L.StrConst (ds @ ds'), #2 str) end | _ => str) | _ => str diff --git a/src/especialize.sml b/src/especialize.sml index d5e93680..2c6799dd 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -110,7 +110,7 @@ fun exp (e, st : state) = | SOME (_, [], _) => (e, st) | SOME (f, xs, xs') => case IM.find (#funcs st, f) of - NONE => ((*print "SHOT DOWN!\n";*) (e, st)) + NONE => ((*print ("SHOT DOWN! " ^ Int.toString f ^ "\n");*) (e, st)) | SOME {name, args, body, typ, tag} => case KM.find (args, xs) of SOME f' => ((*Print.prefaces "Pre-existing" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))];*) @@ -203,6 +203,10 @@ fun specialize' file = body = e, typ = c, tag = tag}) + | DVal (_, n, _, (ENamed n', _), _) => + (case IM.find (funcs, n') of + NONE => funcs + | SOME v => IM.insert (funcs, n, v)) | _ => funcs val (changed, ds) = -- 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(-) 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(-) 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 c5e1cb8c69d62a6ff64cb06d7f263f9c274cb4de Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 8 Nov 2008 09:55:36 -0500 Subject: Generated web servers use getopt() --- src/c/driver.c | 38 ++++++++++++++++++++++++++++---------- 1 file changed, 28 insertions(+), 10 deletions(-) diff --git a/src/c/driver.c b/src/c/driver.c index 1eef9742..be5d7b6c 100644 --- a/src/c/driver.c +++ b/src/c/driver.c @@ -4,12 +4,12 @@ #include #include #include +#include #include #include "urweb.h" -int uw_port = 8080; int uw_backlog = 10; int uw_bufsize = 1024; @@ -298,18 +298,36 @@ int main(int argc, char *argv[]) { struct sockaddr_in my_addr; struct sockaddr_in their_addr; // connector's address information int sin_size, yes = 1; - int nthreads, i, *names; + int uw_port = 8080, nthreads = 1, i, *names, opt; + + while ((opt = getopt(argc, argv, "p:t:")) != -1) { + switch (opt) { + case '?': + fprintf(stderr, "Unknown command-line option"); + return 1; - if (argc < 2) { - fprintf(stderr, "No thread count specified\n"); - return 1; - } + case 'p': + uw_port = atoi(optarg); + if (uw_port <= 0) { + fprintf(stderr, "Invalid port number\n"); + return 1; + } + break; - nthreads = atoi(argv[1]); - if (nthreads <= 0) { - fprintf(stderr, "Invalid thread count\n"); - return 1; + case 't': + nthreads = atoi(optarg); + if (nthreads <= 0) { + fprintf(stderr, "Invalid thread count\n"); + return 1; + } + break; + + default: + fprintf(stderr, "Unexpected getopt() behavior\n"); + return 1; + } } + names = calloc(nthreads, sizeof(int)); sockfd = socket(PF_INET, SOCK_STREAM, 0); // do some error checking! -- cgit v1.2.3 From 443e2b566220b4aa3921527742e1efbabc0eb0e3 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 8 Nov 2008 10:33:58 -0500 Subject: Resolve all tag named in [Basis]; deal with C compilation failure without leaving /tmp files --- src/compiler.sml | 3 ++- src/urweb.grm | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/src/compiler.sml b/src/compiler.sml index de0490c3..bde16fd3 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -567,7 +567,8 @@ fun compile job = (cname, oname, fn () => (OS.FileSys.remove cname; OS.FileSys.remove oname; - OS.FileSys.rmDir dir)) + OS.FileSys.rmDir dir) + handle OS.SysErr _ => OS.FileSys.rmDir dir) end val ename = #exe job in diff --git a/src/urweb.grm b/src/urweb.grm index b49cd793..f344633d 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -1069,7 +1069,7 @@ tagHead: BEGIN_TAG (let val pos = s (BEGIN_TAGleft, BEGIN_TAGright) in (bt, - (EVar ([], bt, Infer), pos)) + (EVar (["Basis"], bt, Infer), pos)) end) | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright))) -- cgit v1.2.3 From 44db3e6164b414f4724c9971fe550036ebb706c3 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 8 Nov 2008 10:46:14 -0500 Subject: [getCookie] reads cookie settings from current page generation --- src/c/urweb.c | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/src/c/urweb.c b/src/c/urweb.c index e50d6965..e8c75275 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -341,6 +341,7 @@ void uw_write_header(uw_context ctx, uw_Basis_string s) { uw_check_headers(ctx, len + 1); strcpy(ctx->outHeaders_front, s); ctx->outHeaders_front += len; + *ctx->outHeaders_front = 0; } static void uw_check(uw_context ctx, size_t extra) { @@ -1172,7 +1173,24 @@ uw_Basis_string uw_Basis_requestHeader(uw_context ctx, uw_Basis_string h) { uw_Basis_string uw_Basis_get_cookie(uw_context ctx, uw_Basis_string c) { int len = strlen(c); - char *s = ctx->headers, *p; + char *s = ctx->headers, *p = ctx->outHeaders; + + while (p = strstr(p, "\nSet-Cookie: ")) { + char *p2; + p += 13; + p2 = strchr(p, '='); + + if (p2) { + size_t sz = strcspn(p2+1, ";\r\n"); + + if (!strncasecmp(p, c, p2 - p)) { + char *ret = uw_malloc(ctx, sz + 1); + memcpy(ret, p2+1, sz); + ret[sz] = 0; + return ret; + } + } + } while (p = strchr(s, ':')) { if (!strncasecmp(s, "Cookie: ", 8) && !strncmp(p + 2, c, len) -- cgit v1.2.3 From dbf4d428936189bba18ffb1d622029c79da39414 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 8 Nov 2008 10:58:59 -0500 Subject: Fix parsing of last input header --- src/c/driver.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/c/driver.c b/src/c/driver.c index be5d7b6c..3c750d67 100644 --- a/src/c/driver.c +++ b/src/c/driver.c @@ -137,7 +137,7 @@ static void *worker(void *data) { failure_kind fk; char *cmd, *path, *headers, path_copy[uw_bufsize+1], *inputs; - *s = 0; + s[2] = 0; if (!(s = strstr(buf, "\r\n"))) { fprintf(stderr, "No newline in buf\n"); -- cgit v1.2.3 From 7d6eed032a2b129056ff264a91076cec68035a34 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 8 Nov 2008 12:12:50 -0500 Subject: Handle EError returning a function; handle multiple cookies in one input header --- src/c/urweb.c | 18 +++++++++++++++--- src/cjr_print.sml | 13 +++++-------- 2 files changed, 20 insertions(+), 11 deletions(-) diff --git a/src/c/urweb.c b/src/c/urweb.c index e8c75275..57584f53 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -1193,9 +1193,21 @@ uw_Basis_string uw_Basis_get_cookie(uw_context ctx, uw_Basis_string c) { } 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; + if (!strncasecmp(s, "Cookie: ", 8)) { + p += 2; + while (1) { + if (!strncmp(p, c, len) + && p + len < ctx->headers_end && p[len] == '=') + return p + 1 + len; + else if (p = strchr(p, ';')) + p += 2; + else if ((s = strchr(s, 0)) && s < ctx->headers_end) { + s += 2; + break; + } + else + return NULL; + } } else { if ((s = strchr(p, 0)) && s < ctx->headers_end) s += 2; diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 3941fdd9..7c13fcb5 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -70,14 +70,8 @@ fun isUnboxable (t : typ) = fun p_typ' par env (t, loc) = case t of - TFun (t1, t2) => parenIf par (box [string "(", - p_typ' true env t2, - space, - string "(*)", - space, - string "(", - p_typ env t1, - string "))"]) + TFun (t1, t2) => (EM.errorAt loc "Function type remains"; + string "") | TRecord i => box [string "struct", space, string "__uws_", @@ -967,6 +961,9 @@ fun p_exp' par env (e, loc) = string "tmp;", newline, string "})"] + | EApp ((EError (e, (TFun (_, ran), _)), loc), _) => + p_exp env (EError (e, ran), loc) + | EFfiApp (m, x, es) => box [string "uw_", p_ident m, string "_", -- cgit v1.2.3 From 91ac4dd03f4130e5e416d495d53237b74a37efc1 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 8 Nov 2008 12:24:23 -0500 Subject: Add help text for generated web servers --- src/c/driver.c | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/src/c/driver.c b/src/c/driver.c index 3c750d67..49537614 100644 --- a/src/c/driver.c +++ b/src/c/driver.c @@ -292,6 +292,10 @@ static void *worker(void *data) { } } +static void help(char *cmd) { + printf("Usage: %s [-p ] [-t ]\n", cmd); +} + int main(int argc, char *argv[]) { // The skeleton for this function comes from Beej's sockets tutorial. int sockfd; // listen on sock_fd @@ -300,16 +304,22 @@ int main(int argc, char *argv[]) { int sin_size, yes = 1; int uw_port = 8080, nthreads = 1, i, *names, opt; - while ((opt = getopt(argc, argv, "p:t:")) != -1) { + while ((opt = getopt(argc, argv, "hp:t:")) != -1) { switch (opt) { case '?': fprintf(stderr, "Unknown command-line option"); + help(argv[0]); return 1; + case 'h': + help(argv[0]); + return 0; + case 'p': uw_port = atoi(optarg); if (uw_port <= 0) { fprintf(stderr, "Invalid port number\n"); + help(argv[0]); return 1; } break; @@ -318,6 +328,7 @@ int main(int argc, char *argv[]) { nthreads = atoi(optarg); if (nthreads <= 0) { fprintf(stderr, "Invalid thread count\n"); + help(argv[0]); return 1; } break; -- cgit v1.2.3 From 901b6d55e625be136ddd677a3d8a36e5068de2ae Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 8 Nov 2008 13:15:00 -0500 Subject: Some small changes while failing to write [restrict] --- src/disjoint.sig | 2 ++ src/disjoint.sml | 8 ++++++++ src/elaborate.sml | 2 +- src/urweb.grm | 16 ++++++++-------- 4 files changed, 19 insertions(+), 9 deletions(-) diff --git a/src/disjoint.sig b/src/disjoint.sig index 025269cf..0d6793c5 100644 --- a/src/disjoint.sig +++ b/src/disjoint.sig @@ -40,4 +40,6 @@ signature DISJOINT = sig val hnormCon : ElabEnv.env * env -> Elab.con -> Elab.con * goal list + val p_env : env -> unit + end diff --git a/src/disjoint.sml b/src/disjoint.sml index 808d8413..c6a8d50f 100644 --- a/src/disjoint.sml +++ b/src/disjoint.sml @@ -53,6 +53,8 @@ fun p2s p = fun pp p = print (p2s p ^ "\n") +fun rp2s (p, ns) = String.concatWith " " (p2s p :: map Int.toString ns) + structure PK = struct type ord_key = piece @@ -104,6 +106,12 @@ structure PM = BinaryMapFn(PK) type env = PS.set PM.map +fun p_env x = + (print "\nDENV:\n"; + PM.appi (fn (p1, ps) => + PS.app (fn p2 => + print (rp2s p1 ^ " ~ " ^ rp2s p2 ^ "\n")) ps) x) + structure E = ElabEnv type goal = ErrorMsg.span * E.env * env * Elab.con * Elab.con diff --git a/src/elaborate.sml b/src/elaborate.sml index e84f5307..17133d93 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -3424,7 +3424,7 @@ fun elabFile basis topStr topSgn env file = [("loc", PD.string (ErrorMsg.spanToString loc)), ("c1", p_con env c1), ("c2", p_con env c2)]; - raise Fail "Unresolve constraint in top.ur")) + raise Fail "Unresolved constraint in top.ur")) | TypeClass _ => raise Fail "Unresolved type class constraint in top.ur") gs val () = subSgn (env', D.empty) topSgn' topSgn diff --git a/src/urweb.grm b/src/urweb.grm index f344633d..5241ed20 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -625,11 +625,11 @@ cargp : SYMBOL (fn (c, k) => ((CAbs (SYMBOL, SOME kind, c), loc), (KArrow (kind, k), loc)) end) - | LBRACK cterm TWIDDLE cterm RBRACK (fn (c, k) => + | LBRACK cexp TWIDDLE cexp RBRACK (fn (c, k) => let val loc = s (LBRACKleft, RBRACKright) in - ((CDisjoint (cterm1, cterm2, c), loc), + ((CDisjoint (cexp1, cexp2, c), loc), k) end) @@ -810,19 +810,19 @@ eargp : SYMBOL (fn (e, t) => ((EAbs ("_", SOME cexp, e), loc), (TFun (cexp, t), loc)) end) - | LPAREN cterm TWIDDLE cterm RPAREN(fn (e, t) => + | LPAREN cexp TWIDDLE cexp RPAREN (fn (e, t) => let val loc = s (LPARENleft, RPARENright) in - ((EDisjoint (cterm1, cterm2, e), loc), - (CDisjoint (cterm1, cterm2, t), loc)) + ((EDisjoint (cexp1, cexp2, e), loc), + (CDisjoint (cexp1, cexp2, t), loc)) end) - | LBRACK cterm TWIDDLE cterm RBRACK(fn (e, t) => + | LBRACK cexp TWIDDLE cexp RBRACK(fn (e, t) => let val loc = s (LBRACKleft, RBRACKright) in - ((EDisjoint (cterm1, cterm2, e), loc), - (CDisjoint (cterm1, cterm2, t), loc)) + ((EDisjoint (cexp1, cexp2, e), loc), + (CDisjoint (cexp1, cexp2, t), loc)) end) eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright)) -- cgit v1.2.3 From 437a207ec01c2ab18bb424cc2d6d36b59f3c8efb Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 8 Nov 2008 14:42:52 -0500 Subject: Broaden set of possible especializations --- src/core_util.sig | 8 +++ src/core_util.sml | 163 ++++++++++++++++++++++++++++++++++++++++++++++++++++ src/especialize.sml | 70 +++++++++++++--------- src/order.sig | 3 +- src/order.sml | 8 +++ src/prim.sig | 1 + src/prim.sml | 12 ++++ 7 files changed, 238 insertions(+), 27 deletions(-) diff --git a/src/core_util.sig b/src/core_util.sig index 2ae75305..51dee8f4 100644 --- a/src/core_util.sig +++ b/src/core_util.sig @@ -73,6 +73,8 @@ structure Con : sig end structure Exp : sig + val compare : Core.exp * Core.exp -> order + datatype binder = RelC of string * Core.kind | NamedC of string * int * Core.kind * Core.con option @@ -108,6 +110,12 @@ structure Exp : sig con : Core.con' -> bool, exp : Core.exp' -> bool} -> Core.exp -> bool + val existsB : {kind : Core.kind' -> bool, + con : 'context * Core.con' -> bool, + exp : 'context * Core.exp' -> bool, + bind : 'context * binder -> 'context} + -> 'context -> Core.exp -> bool + val foldMap : {kind : Core.kind' * 'state -> Core.kind' * 'state, con : Core.con' * 'state -> Core.con' * 'state, exp : Core.exp' * 'state -> Core.exp' * 'state} diff --git a/src/core_util.sml b/src/core_util.sml index 7e1440a1..2352a849 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -331,6 +331,149 @@ end structure Exp = struct +open Order + +fun pcCompare (pc1, pc2) = + case (pc1, pc2) of + (PConVar n1, PConVar n2) => Int.compare (n1, n2) + | (PConVar _, _) => LESS + | (_, PConVar _) => GREATER + + | (PConFfi {mod = m1, datatyp = d1, con = c1, ...}, + PConFfi {mod = m2, datatyp = d2, con = c2, ...}) => + join (String.compare (m1, m2), + fn () => join (String.compare (d1, d2), + fn () => String.compare (c1, c2))) + +fun pCompare ((p1, _), (p2, _)) = + case (p1, p2) of + (PWild, PWild) => EQUAL + | (PWild, _) => LESS + | (_, PWild) => GREATER + + | (PVar _, PVar _) => EQUAL + | (PVar _, _) => LESS + | (_, PVar _) => GREATER + + | (PPrim p1, PPrim p2) => Prim.compare (p1, p2) + | (PPrim _, _) => LESS + | (_, PPrim _) => GREATER + + | (PCon (_, pc1, _, po1), PCon (_, pc2, _, po2)) => + join (pcCompare (pc1, pc2), + fn () => joinO pCompare (po1, po2)) + | (PCon _, _) => LESS + | (_, PCon _) => GREATER + + | (PRecord xps1, PRecord xps2) => + joinL (fn ((x1, p1, _), (x2, p2, _)) => + join (String.compare (x1, x2), + fn () => pCompare (p1, p2))) (xps1, xps2) + +fun compare ((e1, _), (e2, _)) = + case (e1, e2) of + (EPrim p1, EPrim p2) => Prim.compare (p1, p2) + | (EPrim _, _) => LESS + | (_, EPrim _) => GREATER + + | (ERel n1, ERel n2) => Int.compare (n1, n2) + | (ERel _, _) => LESS + | (_, ERel _) => GREATER + + | (ENamed n1, ENamed n2) => Int.compare (n1, n2) + | (ENamed _, _) => LESS + | (_, ENamed _) => GREATER + + | (ECon (_, pc1, _, eo1), ECon (_, pc2, _, eo2)) => + join (pcCompare (pc1, pc2), + fn () => joinO compare (eo1, eo2)) + | (ECon _, _) => LESS + | (_, ECon _) => GREATER + + | (EFfi (f1, x1), EFfi (f2, x2)) => + join (String.compare (f1, f2), + fn () => String.compare (x1, x2)) + | (EFfi _, _) => LESS + | (_, EFfi _) => GREATER + + | (EFfiApp (f1, x1, es1), EFfiApp (f2, x2, es2)) => + join (String.compare (f1, f2), + fn () => join (String.compare (x1, x2), + fn () => joinL compare (es1, es2))) + | (EFfiApp _, _) => LESS + | (_, EFfiApp _) => GREATER + + | (EApp (f1, x1), EApp (f2, x2)) => + join (compare (f1, f2), + fn () => compare (x1, x2)) + | (EApp _, _) => LESS + | (_, EApp _) => GREATER + + | (EAbs (_, _, _, e1), EAbs (_, _, _, e2)) => compare (e1, e2) + | (EAbs _, _) => LESS + | (_, EAbs _) => GREATER + + | (ECApp (f1, x1), ECApp (f2, x2)) => + join (compare (f1, f2), + fn () => Con.compare (x1, x2)) + | (ECApp _, _) => LESS + | (_, ECApp _) => GREATER + + | (ECAbs (_, _, e1), ECAbs (_, _, e2)) => compare (e1, e2) + | (ECAbs _, _) => LESS + | (_, ECAbs _) => GREATER + + | (ERecord xes1, ERecord xes2) => + joinL (fn ((x1, e1, _), (x2, e2, _)) => + join (Con.compare (x1, x2), + fn () => compare (e1, e2))) (xes1, xes2) + | (ERecord _, _) => LESS + | (_, ERecord _) => GREATER + + | (EField (e1, c1, _), EField (e2, c2, _)) => + join (compare (e1, e2), + fn () => Con.compare (c1, c2)) + | (EField _, _) => LESS + | (_, EField _) => GREATER + + | (EConcat (x1, _, y1, _), EConcat (x2, _, y2, _)) => + join (compare (x1, x2), + fn () => compare (y1, y2)) + | (EConcat _, _) => LESS + | (_, EConcat _) => GREATER + + | (ECut (e1, c1, _), ECut (e2, c2, _)) => + join (compare (e1, e2), + fn () => Con.compare (c1, c2)) + | (ECut _, _) => LESS + | (_, ECut _) => GREATER + + | (EFold _, EFold _) => EQUAL + | (EFold _, _) => LESS + | (_, EFold _) => GREATER + + | (ECase (e1, pes1, _), ECase (e2, pes2, _)) => + join (compare (e1, e2), + fn () => joinL (fn ((p1, e1), (p2, e2)) => + join (pCompare (p1, p2), + fn () => compare (e1, e2))) (pes1, pes2)) + | (ECase _, _) => LESS + | (_, ECase _) => GREATER + + | (EWrite e1, EWrite e2) => compare (e1, e2) + | (EWrite _, _) => LESS + | (_, EWrite _) => GREATER + + | (EClosure (n1, es1), EClosure (n2, es2)) => + join (Int.compare (n1, n2), + fn () => joinL compare (es1, es2)) + | (EClosure _, _) => LESS + | (_, EClosure _) => GREATER + + | (ELet (_, _, x1, e1), ELet (_, _, x2, e2)) => + join (compare (x1, x2), + fn () => compare (e1, e2)) + datatype binder = RelC of string * kind | NamedC of string * int * kind * con option @@ -585,6 +728,26 @@ fun exists {kind, con, exp} k = S.Return _ => true | S.Continue _ => false +fun existsB {kind, con, exp, bind} ctx k = + case mapfoldB {kind = fn k => fn () => + if kind k then + S.Return () + else + S.Continue (k, ()), + con = fn ctx => fn c => fn () => + if con (ctx, c) then + S.Return () + else + S.Continue (c, ()), + exp = fn ctx => fn e => fn () => + if exp (ctx, e) then + S.Return () + else + S.Continue (e, ()), + bind = bind} ctx k () of + S.Return _ => true + | S.Continue _ => false + fun foldMap {kind, con, exp} s e = case mapfold {kind = fn k => fn s => S.Continue (kind (k, s)), con = fn c => fn s => S.Continue (con (c, s)), diff --git a/src/especialize.sml b/src/especialize.sml index 2c6799dd..adb444b5 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -32,39 +32,57 @@ open Core structure E = CoreEnv structure U = CoreUtil -datatype skey = - Named of int - | App of skey * skey +type skey = exp structure K = struct -type ord_key = skey list -fun compare' (k1, k2) = - case (k1, k2) of - (Named n1, Named n2) => Int.compare (n1, n2) - | (Named _, _) => LESS - | (_, Named _) => GREATER - - | (App (x1, y1), App (x2, y2)) => Order.join (compare' (x1, x2), fn () => compare' (y1, y2)) - -val compare = Order.joinL compare' +type ord_key = exp list +val compare = Order.joinL U.Exp.compare end structure KM = BinaryMapFn(K) structure IM = IntBinaryMap -fun skeyIn (e, _) = +val sizeOf = U.Exp.fold {kind = fn (_, n) => n, + con = fn (_, n) => n, + exp = fn (_, n) => n + 1} + 0 + +val isOpen = U.Exp.existsB {kind = fn _ => false, + con = fn ((nc, _), c) => + case c of + CRel n => n >= nc + | _ => false, + exp = fn ((_, ne), e) => + case e of + ERel n => n >= ne + | _ => false, + bind = fn ((nc, ne), b) => + case b of + U.Exp.RelC _ => (nc + 1, ne) + | U.Exp.RelE _ => (nc, ne + 1) + | _ => (nc, ne)} + (0, 0) + +fun baseBad (e, _) = case e of - ENamed n => SOME (Named n) - | EApp (e1, e2) => - (case (skeyIn e1, skeyIn e2) of - (SOME k1, SOME k2) => SOME (App (k1, k2)) - | _ => NONE) - | _ => NONE - -fun skeyOut (k, loc) = - case k of - Named n => (ENamed n, loc) - | App (k1, k2) => (EApp (skeyOut (k1, loc), skeyOut (k2, loc)), loc) + EAbs (_, _, _, e) => sizeOf e > 20 + | ENamed _ => false + | _ => true + +fun isBad e = + case e of + (ERecord xes, _) => + length xes > 10 + orelse List.exists (fn (_, e, _) => baseBad e) xes + | _ => baseBad e + +fun skeyIn e = + if isBad e orelse isOpen e then + NONE + else + SOME e + +fun skeyOut e = e type func = { name : string, @@ -126,7 +144,7 @@ fun exp (e, st : state) = (_, _, []) => SOME (body, typ) | (EAbs (_, _, _, body'), TFun (_, typ'), x :: xs) => let - val body'' = E.subExpInExp (0, skeyOut (x, #2 body)) body' + val body'' = E.subExpInExp (0, skeyOut x) body' in (*Print.prefaces "espec" [("body'", CorePrint.p_exp CoreEnv.empty body'), ("body''", CorePrint.p_exp CoreEnv.empty body'')];*) diff --git a/src/order.sig b/src/order.sig index c648f78b..fcee69ea 100644 --- a/src/order.sig +++ b/src/order.sig @@ -31,5 +31,6 @@ signature ORDER = sig val join : order * (unit -> order) -> order val joinL : ('a * 'b -> order) -> 'a list * 'b list -> order - + val joinO : ('a * 'b -> order) -> 'a option * 'b option -> order + end diff --git a/src/order.sml b/src/order.sml index 4a78823b..3f5bce65 100644 --- a/src/order.sml +++ b/src/order.sml @@ -42,4 +42,12 @@ fun joinL f (os1, os2) = join (f (h1, h2), fn () => joinL f (t1, t2)) | (_ :: _, nil) => GREATER +fun joinO f (v1, v2) = + case (v1, v2) of + (NONE, NONE) => EQUAL + | (NONE, _) => LESS + | (_, NONE) => GREATER + + | (SOME v1, SOME v2) => f (v1, v2) + end diff --git a/src/prim.sig b/src/prim.sig index 73f23b77..3083a26e 100644 --- a/src/prim.sig +++ b/src/prim.sig @@ -36,5 +36,6 @@ signature PRIM = sig val p_t_GCC : t Print.printer val equal : t * t -> bool + val compare : t * t -> order end diff --git a/src/prim.sml b/src/prim.sml index 2c24fa0a..daf666e8 100644 --- a/src/prim.sml +++ b/src/prim.sml @@ -67,4 +67,16 @@ fun equal x = | _ => false +fun compare (p1, p2) = + case (p1, p2) of + (Int n1, Int n2) => Int64.compare (n1, n2) + | (Int _, _) => LESS + | (_, Int _) => GREATER + + | (Float n1, Float n2) => Real64.compare (n1, n2) + | (Float _, _) => LESS + | (_, Float _) => GREATER + + | (String n1, String n2) => String.compare (n1, n2) + end -- cgit v1.2.3 From b5cfe6cf7eeff856dc3ddca5ad4b2b5bb894f7ee Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 8 Nov 2008 16:02:59 -0500 Subject: Especialize handles records better --- src/core_print.sml | 2 +- src/corify.sml | 4 ++-- src/elaborate.sml | 8 ++++---- src/especialize.sml | 17 +++++++++++++++-- src/expl_print.sml | 14 +++++++------- 5 files changed, 29 insertions(+), 16 deletions(-) diff --git a/src/core_print.sml b/src/core_print.sml index 7de31568..c4341e51 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -93,7 +93,7 @@ fun p_con' par env (c, _) = string (#1 (E.lookupCNamed env n) ^ "__" ^ Int.toString n) else string (#1 (E.lookupCNamed env n))) - handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n)) + handle E.UnboundNamed _ => string ("UNBOUNDN_" ^ Int.toString n)) | CFfi (m, x) => box [string "FFI(", string m, string ".", string x, string ")"] | CApp (c1, c2) => parenIf par (box [p_con env c1, diff --git a/src/corify.sml b/src/corify.sml index 2b90a8f0..fdb4e7b7 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -387,7 +387,7 @@ fun bindStr ({basis, cons, constructors, vals, strs, funs, fun lookupStrById ({basis, strs, ...} : t) n = case IM.find (strs, n) of - NONE => raise Fail "Corify.St.lookupStrById" + NONE => raise Fail ("Corify.St.lookupStrById(" ^ Int.toString n ^ ")") | SOME f => dummy (basis, f) fun lookupStrByName (m, {basis, current = FNormal {strs, ...}, ...} : t) = @@ -602,7 +602,7 @@ fun 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) = +fun corifyDecl mods (all as (d, loc : EM.span), st) = case d of L.DCon (x, n, k, c) => let diff --git a/src/elaborate.sml b/src/elaborate.sml index 17133d93..70429c1b 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2615,14 +2615,14 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = | (L'.SgnFun (m1, n1, dom1, ran1), L'.SgnFun (m2, n2, dom2, ran2)) => let - val ran1 = + val ran2 = if n1 = n2 then - ran1 + ran2 else - subStrInSgn (n1, n2) ran1 + subStrInSgn (n2, n1) ran2 in subSgn (env, denv) dom2 dom1; - subSgn (E.pushStrNamedAs env m2 n2 dom2, denv) ran1 ran2 + subSgn (E.pushStrNamedAs env m1 n1 dom2, denv) ran1 ran2 end | _ => sgnError env (SgnWrongForm (sgn1, sgn2))) diff --git a/src/especialize.sml b/src/especialize.sml index adb444b5..92e29da3 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -106,6 +106,11 @@ fun exp (e, st : state) = fun getApp e = case e of ENamed f => SOME (f, [], []) + | EField ((ERecord xes, _), (CName x, _), _) => + (case List.find (fn ((CName x', _), _,_) => x' = x + | _ => false) xes of + NONE => NONE + | SOME (_, (e, _), _) => getApp e) | EApp (e1, e2) => (case getApp (#1 e1) of NONE => NONE @@ -125,10 +130,18 @@ fun exp (e, st : state) = in case getApp e of NONE => (e, st) - | SOME (_, [], _) => (e, st) + | SOME (f, [], xs') => (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) + (ENamed f, ErrorMsg.dummySpan) xs'), st) | SOME (f, xs, xs') => case IM.find (#funcs st, f) of - NONE => ((*print ("SHOT DOWN! " ^ Int.toString f ^ "\n");*) (e, st)) + NONE => + let + val e = foldl (fn (arg, e) => (EApp (e, skeyOut arg), ErrorMsg.dummySpan)) + (ENamed f, ErrorMsg.dummySpan) xs + in + (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) + e xs'), st) + end | SOME {name, args, body, typ, tag} => case KM.find (args, xs) of SOME f' => ((*Print.prefaces "Pre-existing" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))];*) diff --git a/src/expl_print.sml b/src/expl_print.sml index 2d41ab34..e3153ef2 100644 --- a/src/expl_print.sml +++ b/src/expl_print.sml @@ -97,7 +97,7 @@ fun p_con' par env (c, _) = | CModProj (m1, ms, x) => let val m1x = #1 (E.lookupStrNamed env m1) - handle E.UnboundNamed _ => "UNBOUND" + handle E.UnboundNamed _ => "UNBOUND" ^ Int.toString m1 val m1s = if !debug then m1x ^ "__" ^ Int.toString m1 @@ -226,7 +226,7 @@ fun p_exp' par env (e, loc) = | EModProj (m1, ms, x) => let val (m1x, sgn) = E.lookupStrNamed env m1 - handle E.UnboundNamed _ => ("UNBOUND", (SgnConst [], loc)) + handle E.UnboundNamed _ => ("UNBOUND" ^ Int.toString m1, (SgnConst [], loc)) val m1s = if !debug then m1x ^ "__" ^ Int.toString m1 @@ -487,11 +487,11 @@ and p_sgn env (sgn, loc) = newline, string "end"] | SgnVar n => string ((#1 (E.lookupSgnNamed env n)) - handle E.UnboundNamed _ => "UNBOUND") + handle E.UnboundNamed _ => "UNBOUND" ^ Int.toString n) | SgnFun (x, n, sgn, sgn') => box [string "functor", space, string "(", - string x, + p_named x n, space, string ":", space, @@ -515,7 +515,7 @@ and p_sgn env (sgn, loc) = | SgnProj (m1, ms, x) => let val (m1x, sgn) = E.lookupStrNamed env m1 - handle E.UnboundNamed _ => ("UNBOUND", (SgnConst [], loc)) + handle E.UnboundNamed _ => ("UNBOUND" ^ Int.toString m1, (SgnConst [], loc)) val m1s = if !debug then m1x ^ "__" ^ Int.toString m1 @@ -643,7 +643,7 @@ and p_str env (str, _) = | StrVar n => let val x = #1 (E.lookupStrNamed env n) - handle E.UnboundNamed _ => "UNBOUND" + handle E.UnboundNamed _ => "UNBOUND" ^ Int.toString n val s = if !debug then x ^ "__" ^ Int.toString n @@ -662,7 +662,7 @@ and p_str env (str, _) = box [string "functor", space, string "(", - string x, + p_named x n, space, string ":", space, -- cgit v1.2.3 From bf14288c4da80f65aa920b001cf8e3070c8b4c3e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 8 Nov 2008 16:47:04 -0500 Subject: Better detection of [let] substitution opportunities --- src/mono_reduce.sml | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index dce6ef35..942a9291 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -199,7 +199,7 @@ datatype event = WritePage | ReadDb | WriteDb - | UseRel of int + | UseRel | Unsure fun p_event e = @@ -210,7 +210,7 @@ fun p_event e = WritePage => string "WritePage" | ReadDb => string "ReadDb" | WriteDb => string "WriteDb" - | UseRel n => string ("UseRel" ^ Int.toString n) + | UseRel => string "UseRel" | Unsure => string "Unsure" end @@ -249,7 +249,7 @@ fun reduce file = fun summarize d (e, _) = case e of EPrim _ => [] - | ERel n => if n >= d then [UseRel (n - d)] else [] + | ERel n => if n = d then [UseRel] else [] | ENamed _ => [] | ECon (_, _, NONE) => [] | ECon (_, _, SOME e) => summarize d e @@ -275,7 +275,11 @@ fun reduce file = else [Unsure] end - | ERel n => List.revAppend (ls, [UseRel (n - d), Unsure]) + | ERel n => List.revAppend (ls, + if n = d then + [UseRel, Unsure] + else + [Unsure]) | EApp (f, x) => unravel (#1 f, summarize d x @ ls) | _ => [Unsure] @@ -435,7 +439,7 @@ fun reduce file = fun verifyUnused eff = case eff of - UseRel r => r <> 0 + UseRel => false | _ => true fun verifyCompatible effs = @@ -444,11 +448,7 @@ fun reduce file = | eff :: effs => case eff of Unsure => false - | UseRel r => - if r = 0 then - List.all verifyUnused effs - else - verifyCompatible effs + | UseRel => List.all verifyUnused effs | WritePage => not writesPage andalso verifyCompatible effs | ReadDb => not writesDb andalso verifyCompatible effs | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs @@ -458,7 +458,7 @@ fun reduce file = ("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 + if List.null effs_e' orelse verifyCompatible effs_b then trySub () else e -- cgit v1.2.3 From 23d4ee74243e0d9d630c863e83403d25e926ff88 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 9 Nov 2008 11:53:52 -0500 Subject: Especialize working reasonably well; need to add new closure representation pass --- src/compiler.sml | 7 ++ src/core_print.sml | 3 +- src/core_util.sig | 6 ++ src/core_util.sml | 7 ++ src/especialize.sml | 236 ++++++++++++++++++++++++++++++--------------------- src/reduce_local.sig | 34 ++++++++ src/reduce_local.sml | 69 +++++++++++++++ src/sources | 3 + src/tag.sml | 2 - 9 files changed, 267 insertions(+), 100 deletions(-) create mode 100644 src/reduce_local.sig create mode 100644 src/reduce_local.sml diff --git a/src/compiler.sml b/src/compiler.sml index bde16fd3..9705cfaf 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -411,6 +411,13 @@ val corify = { val toCorify = transform corify "corify" o toExplify +(*val reduce_local = { + func = ReduceLocal.reduce, + print = CorePrint.p_file CoreEnv.empty +} + +val toReduce_local = transform reduce_local "reduce_local" o toCorify*) + val especialize = { func = ESpecialize.specialize, print = CorePrint.p_file CoreEnv.empty diff --git a/src/core_print.sml b/src/core_print.sml index c4341e51..af43e401 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -482,7 +482,8 @@ fun p_decl env (dAll as (d, _) : decl) = space, string "as", space, - p_con env (#2 (E.lookupENamed env n))] + (p_con env (#2 (E.lookupENamed env n)) + handle E.UnboundNamed _ => string "UNBOUND")] | DTable (x, n, c, s) => box [string "table", space, p_named x n, diff --git a/src/core_util.sig b/src/core_util.sig index 51dee8f4..e435aeaf 100644 --- a/src/core_util.sig +++ b/src/core_util.sig @@ -175,6 +175,12 @@ structure File : sig bind : 'context * binder -> 'context} -> 'context -> Core.file -> Core.file + val map : {kind : Core.kind' -> Core.kind', + con : Core.con' -> Core.con', + exp : Core.exp' -> Core.exp', + decl : Core.decl' -> Core.decl'} + -> Core.file -> Core.file + val fold : {kind : Core.kind' * 'state -> 'state, con : Core.con' * 'state -> 'state, exp : Core.exp' * 'state -> 'state, diff --git a/src/core_util.sml b/src/core_util.sml index 2352a849..4d72f57e 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -953,6 +953,13 @@ fun mapB {kind, con, exp, decl, bind} ctx ds = S.Continue (ds, ()) => ds | S.Return _ => raise Fail "CoreUtil.File.mapB: Impossible" +fun map {kind, con, exp, decl} ds = + mapB {kind = kind, + con = fn () => con, + exp = fn () => exp, + decl = fn () => decl, + bind = fn _ => ()} () ds + fun fold {kind, con, exp, decl} s d = case mapfold {kind = fn k => fn s => S.Continue (k, kind (k, s)), con = fn c => fn s => S.Continue (c, con (c, s)), diff --git a/src/especialize.sml b/src/especialize.sml index 92e29da3..cc583044 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -41,6 +41,7 @@ end structure KM = BinaryMapFn(K) structure IM = IntBinaryMap +structure IS = IntBinarySet val sizeOf = U.Exp.fold {kind = fn (_, n) => n, con = fn (_, n) => n, @@ -101,109 +102,148 @@ type state = { fun kind (k, st) = (k, st) fun con (c, st) = (c, st) -fun exp (e, st : state) = +fun specialize' file = let - fun getApp e = + fun default (_, fs) = fs + + fun actionableExp (e, fs) = case e of - ENamed f => SOME (f, [], []) - | EField ((ERecord xes, _), (CName x, _), _) => - (case List.find (fn ((CName x', _), _,_) => x' = x - | _ => false) xes of - NONE => NONE - | SOME (_, (e, _), _) => getApp e) - | EApp (e1, e2) => - (case getApp (#1 e1) of - NONE => NONE - | SOME (f, xs, xs') => - let - val k = - if List.null xs' then - skeyIn e2 + ERecord xes => + foldl (fn (((CName s, _), e, _), fs) => + if s = "Action" orelse s = "Link" then + let + fun findHead (e, _) = + case e of + ENamed n => IS.add (fs, n) + | EApp (e, _) => findHead e + | _ => fs + in + findHead e + end + else + fs + | (_, fs) => fs) + fs xes + | _ => fs + + val actionable = + U.File.fold {kind = default, + con = default, + exp = actionableExp, + decl = default} + IS.empty file + + fun exp (e, st : state) = + let + fun getApp e = + case e of + ENamed f => SOME (f, [], []) + | EApp (e1, e2) => + (case getApp (#1 e1) of + NONE => NONE + | SOME (f, xs, xs') => + let + val k = + if List.null xs' then + skeyIn e2 + else + NONE + in + case k of + NONE => SOME (f, xs, xs' @ [e2]) + | SOME k => SOME (f, xs @ [k], xs') + end) + | _ => NONE + in + case getApp e of + NONE => (e, st) + | SOME (f, [], []) => (e, st) + | SOME (f, [], xs') => + (case IM.find (#funcs st, f) of + NONE => (e, st) + | SOME {typ, body, ...} => + let + val functionInside = U.Con.exists {kind = fn _ => false, + con = fn TFun _ => true + | CFfi ("Basis", "transaction") => true + | _ => false} + + fun hasFunarg (t, xs) = + case (t, xs) of + ((TFun (dom, ran), _), _ :: xs) => + functionInside dom + orelse hasFunarg (ran, xs) + | _ => false + in + if List.all (fn (ERel _, _) => false | _ => true) xs' + andalso not (IS.member (actionable, f)) + andalso hasFunarg (typ, xs') then + (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) + body xs'), + st) else - NONE - in - case k of - NONE => SOME (f, xs, xs' @ [e2]) - | SOME k => SOME (f, xs @ [k], xs') - end) - | _ => NONE - in - case getApp e of - NONE => (e, st) - | SOME (f, [], xs') => (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) - (ENamed f, ErrorMsg.dummySpan) xs'), st) - | SOME (f, xs, xs') => - case IM.find (#funcs st, f) of - NONE => - let - val e = foldl (fn (arg, e) => (EApp (e, skeyOut arg), ErrorMsg.dummySpan)) - (ENamed f, ErrorMsg.dummySpan) xs - in - (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) - e xs'), st) - end - | SOME {name, args, body, typ, tag} => - case KM.find (args, xs) of - SOME f' => ((*Print.prefaces "Pre-existing" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))];*) - (#1 (foldl (fn (e, arg) => (EApp (e, arg), ErrorMsg.dummySpan)) - (ENamed f', ErrorMsg.dummySpan) xs'), - st)) - | NONE => - let - (*val () = Print.prefaces "New" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))]*) - - fun subBody (body, typ, xs) = - case (#1 body, #1 typ, xs) of - (_, _, []) => SOME (body, typ) - | (EAbs (_, _, _, body'), TFun (_, typ'), x :: xs) => - let - val body'' = E.subExpInExp (0, skeyOut x) body' - in - (*Print.prefaces "espec" [("body'", CorePrint.p_exp CoreEnv.empty body'), - ("body''", CorePrint.p_exp CoreEnv.empty body'')];*) - subBody (body'', - typ', - xs) - end - | _ => NONE - in - case subBody (body, typ, xs) of - NONE => (e, st) - | SOME (body', typ') => - let - val f' = #maxName st - (*val () = print ("f' = " ^ Int.toString f' ^ "\n")*) - val funcs = IM.insert (#funcs st, f, {name = name, - args = KM.insert (args, xs, f'), - body = body, - typ = typ, - tag = tag}) - val st = { - maxName = f' + 1, - funcs = funcs, - decls = #decls st - } - - val (body', st) = specExp st body' - val e' = foldl (fn (e, arg) => (EApp (e, arg), ErrorMsg.dummySpan)) - (ENamed f', ErrorMsg.dummySpan) xs' - in - (#1 e', - {maxName = #maxName st, - funcs = #funcs st, - decls = (name, f', typ', body', tag) :: #decls st}) - end - end - end + (e, st) + end) + | SOME (f, xs, xs') => + case IM.find (#funcs st, f) of + NONE => (e, st) + | SOME {name, args, body, typ, tag} => + case KM.find (args, xs) of + SOME f' => (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) + (ENamed f', ErrorMsg.dummySpan) xs'), + st) + | NONE => + let + fun subBody (body, typ, xs) = + case (#1 body, #1 typ, xs) of + (_, _, []) => SOME (body, typ) + | (EAbs (_, _, _, body'), TFun (_, typ'), x :: xs) => + let + val body'' = E.subExpInExp (0, skeyOut x) body' + in + subBody (body'', + typ', + xs) + end + | _ => NONE + in + case subBody (body, typ, xs) of + NONE => (e, st) + | SOME (body', typ') => + let + val f' = #maxName st + val funcs = IM.insert (#funcs st, f, {name = name, + args = KM.insert (args, + xs, f'), + body = body, + typ = typ, + tag = tag}) + val st = { + maxName = f' + 1, + funcs = funcs, + decls = #decls st + } -and specExp st = U.Exp.foldMap {kind = kind, con = con, exp = exp} st + val (body', st) = specExp st body' + val e' = foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) + (ENamed f', ErrorMsg.dummySpan) xs' + in + (#1 e', + {maxName = #maxName st, + funcs = #funcs st, + decls = (name, f', typ', body', tag) :: #decls st}) + end + end + end + + and specExp st = U.Exp.foldMap {kind = kind, con = con, exp = exp} st + + fun decl (d, st) = (d, st) + + val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl} -fun decl (d, st) = (d, st) -val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl} -fun specialize' file = - let fun doDecl (d, (st : state, changed)) = let val funcs = #funcs st @@ -223,7 +263,9 @@ fun specialize' file = funcs = funcs, decls = []} + (*val () = Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)]*) val (d', st) = specDecl st d + (*val () = print "/decl\n"*) val funcs = #funcs st val funcs = @@ -267,7 +309,7 @@ fun specialize file = val (changed, file) = specialize' file in if changed then - specialize file + specialize (ReduceLocal.reduce file) else file end diff --git a/src/reduce_local.sig b/src/reduce_local.sig new file mode 100644 index 00000000..3c76263a --- /dev/null +++ b/src/reduce_local.sig @@ -0,0 +1,34 @@ +(* 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. + *) + +(* Simplify a Core program algebraically, without unfolding definitions *) + +signature REDUCE_LOCAL = sig + + val reduce : Core.file -> Core.file + +end diff --git a/src/reduce_local.sml b/src/reduce_local.sml new file mode 100644 index 00000000..6a6d80a8 --- /dev/null +++ b/src/reduce_local.sml @@ -0,0 +1,69 @@ +(* 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. + *) + +(* Simplify a Core program algebraically, without unfolding definitions *) + +structure ReduceLocal :> REDUCE_LOCAL = struct + +open Core + +structure E = CoreEnv +structure U = CoreUtil + +val subExpInExp = E.subExpInExp + +fun default x = x + +fun exp (e : exp') = + let + (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp env (e, ErrorMsg.dummySpan))]*) + + val r = case e of + EApp ((EAbs (x, t, _, e1), loc), e2) => + ((*Print.prefaces "Substitute" [("x", Print.PD.string x), + ("t", CorePrint.p_con CoreEnv.empty t)];*) + #1 (reduceExp (subExpInExp (0, e2) e1))) + + | EField ((ERecord xes, _), (CName x, _), _) => + (case List.find (fn ((CName x', _), _, _) => x' = x + | _ => false) xes of + SOME (_, (e, _), _) => e + | NONE => e) + + | _ => e + in + (*Print.prefaces "exp'" [("e", CorePrint.p_exp env (e, ErrorMsg.dummySpan)), + ("r", CorePrint.p_exp env (r, ErrorMsg.dummySpan))];*) + + r + end + +and reduceExp e = U.Exp.map {kind = default, con = default, exp = exp} e + +val reduce = U.File.map {kind = default, con = default, exp = exp, decl = default} + +end diff --git a/src/sources b/src/sources index 9fd90e8c..252ffe44 100644 --- a/src/sources +++ b/src/sources @@ -96,6 +96,9 @@ unpoly.sml specialize.sig specialize.sml +reduce_local.sig +reduce_local.sml + especialize.sig especialize.sml diff --git a/src/tag.sml b/src/tag.sml index 34595732..b19a0544 100644 --- a/src/tag.sml +++ b/src/tag.sml @@ -80,8 +80,6 @@ fun exp env (e, s) = | _ => (ErrorMsg.errorAt loc "Invalid link expression"; (0, [])) - - val (f, args) = unravel e val (cn, count, tags, newTags) = -- cgit v1.2.3 From b1e02a9df5f341b5e1298085df0aef70f11ae424 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 9 Nov 2008 12:41:34 -0500 Subject: Remove an extra line --- src/especialize.sml | 1 - 1 file changed, 1 deletion(-) diff --git a/src/especialize.sml b/src/especialize.sml index cc583044..d6af4e04 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -314,5 +314,4 @@ fun specialize file = file end - end -- cgit v1.2.3 From 6d1ea82d46cb6f34b45d6e5abab29cacf006f1fb Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 9 Nov 2008 16:54:42 -0500 Subject: Defunctionalization gets CommentBlog working --- src/compiler.sig | 2 + src/compiler.sml | 9 +- src/core_util.sig | 12 +++ src/core_util.sml | 17 ++++ src/defunc.sig | 32 +++++++ src/defunc.sml | 256 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/sources | 3 + 7 files changed, 330 insertions(+), 1 deletion(-) create mode 100644 src/defunc.sig create mode 100644 src/defunc.sml diff --git a/src/compiler.sig b/src/compiler.sig index 6094da89..402706be 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -65,6 +65,7 @@ signature COMPILER = sig val especialize : (Core.file, Core.file) phase val core_untangle : (Core.file, Core.file) phase val shake : (Core.file, Core.file) phase + val defunc : (Core.file, Core.file) phase val tag : (Core.file, Core.file) phase val reduce : (Core.file, Core.file) phase val unpoly : (Core.file, Core.file) phase @@ -89,6 +90,7 @@ signature COMPILER = sig val toEspecialize : (string, Core.file) transform val toCore_untangle : (string, Core.file) transform val toShake1 : (string, Core.file) transform + val toDefunc : (string, Core.file) transform val toTag : (string, Core.file) transform val toReduce : (string, Core.file) transform val toUnpoly : (string, Core.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 9705cfaf..93a03169 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -439,12 +439,19 @@ val shake = { val toShake1 = transform shake "shake1" o toCore_untangle +val defunc = { + func = Defunc.defunc, + print = CorePrint.p_file CoreEnv.empty +} + +val toDefunc = transform defunc "defunc" o toShake1 + val tag = { func = Tag.tag, print = CorePrint.p_file CoreEnv.empty } -val toTag = transform tag "tag" o toShake1 +val toTag = transform tag "tag" o toDefunc val reduce = { func = Reduce.reduce, diff --git a/src/core_util.sig b/src/core_util.sig index e435aeaf..100932c3 100644 --- a/src/core_util.sig +++ b/src/core_util.sig @@ -105,6 +105,12 @@ structure Exp : sig con : Core.con' * 'state -> 'state, exp : Core.exp' * 'state -> 'state} -> 'state -> Core.exp -> 'state + + val foldB : {kind : Core.kind' * 'state -> 'state, + con : 'context * Core.con' * 'state -> 'state, + exp : 'context * Core.exp' * 'state -> 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Core.exp -> 'state val exists : {kind : Core.kind' -> bool, con : Core.con' -> bool, @@ -148,6 +154,12 @@ structure Decl : sig exp : Core.exp' * 'state -> Core.exp' * 'state, decl : Core.decl' * 'state -> Core.decl' * 'state} -> 'state -> Core.decl -> Core.decl * 'state + val foldMapB : {kind : Core.kind' * 'state -> Core.kind' * 'state, + con : 'context * Core.con' * 'state -> Core.con' * 'state, + exp : 'context * Core.exp' * 'state -> Core.exp' * 'state, + decl : 'context * Core.decl' * 'state -> Core.decl' * 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Core.decl -> Core.decl * 'state end structure File : sig diff --git a/src/core_util.sml b/src/core_util.sml index 4d72f57e..f7e92f51 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -709,6 +709,14 @@ fun fold {kind, con, exp} s e = S.Continue (_, s) => s | S.Return _ => raise Fail "CoreUtil.Exp.fold: Impossible" +fun foldB {kind, con, exp, bind} ctx s e = + case mapfoldB {kind = fn k => fn s => S.Continue (k, kind (k, s)), + con = fn ctx => fn c => fn s => S.Continue (c, con (ctx, c, s)), + exp = fn ctx => fn e => fn s => S.Continue (e, exp (ctx, e, s)), + bind = bind} ctx e s of + S.Continue (_, s) => s + | S.Return _ => raise Fail "CoreUtil.Exp.foldB: Impossible" + fun exists {kind, con, exp} k = case mapfold {kind = fn k => fn () => if kind k then @@ -861,6 +869,15 @@ fun foldMap {kind, con, exp, decl} s d = S.Continue v => v | S.Return _ => raise Fail "CoreUtil.Decl.foldMap: Impossible" +fun foldMapB {kind, con, exp, decl, bind} ctx s d = + case mapfoldB {kind = fn k => fn s => S.Continue (kind (k, s)), + con = fn ctx => fn c => fn s => S.Continue (con (ctx, c, s)), + exp = fn ctx => fn e => fn s => S.Continue (exp (ctx, e, s)), + decl = fn ctx => fn d => fn s => S.Continue (decl (ctx, d, s)), + bind = bind} ctx d s of + S.Continue v => v + | S.Return _ => raise Fail "CoreUtil.Decl.foldMapB: Impossible" + end structure File = struct diff --git a/src/defunc.sig b/src/defunc.sig new file mode 100644 index 00000000..6e8f2136 --- /dev/null +++ b/src/defunc.sig @@ -0,0 +1,32 @@ +(* 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. + *) + +signature DEFUNC = sig + + val defunc : Core.file -> Core.file + +end diff --git a/src/defunc.sml b/src/defunc.sml new file mode 100644 index 00000000..8771d782 --- /dev/null +++ b/src/defunc.sml @@ -0,0 +1,256 @@ +(* 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. + *) + +structure Defunc :> DEFUNC = struct + +open Core + +structure E = CoreEnv +structure U = CoreUtil + +structure IS = IntBinarySet + +val functionInside = U.Con.exists {kind = fn _ => false, + con = fn TFun _ => true + | CFfi ("Basis", "transaction") => true + | _ => false} + +val freeVars = U.Exp.foldB {kind = fn (_, xs) => xs, + con = fn (_, _, xs) => xs, + exp = fn (bound, e, xs) => + case e of + ERel x => + if x >= bound then + IS.add (xs, x - bound) + else + xs + | _ => xs, + bind = fn (bound, b) => + case b of + U.Exp.RelE _ => bound + 1 + | _ => bound} + 0 IS.empty + +fun positionOf (v : int, ls) = + let + fun pof (pos, ls) = + case ls of + [] => raise Fail "Defunc.positionOf" + | v' :: ls' => + if v = v' then + pos + else + pof (pos + 1, ls') + in + pof (0, ls) + end + +fun squish fvs = + U.Exp.mapB {kind = fn k => k, + con = fn _ => fn c => c, + exp = fn bound => fn e => + case e of + ERel x => + if x >= bound then + ERel (positionOf (x - bound, fvs) + bound) + else + e + | _ => e, + bind = fn (bound, b) => + case b of + U.Exp.RelE _ => bound + 1 + | _ => bound} + 0 + +fun default (_, x, st) = (x, st) + +datatype 'a search = + Yes + | No + | Maybe of 'a + +structure EK = struct +type ord_key = exp +val compare = U.Exp.compare +end + +structure EM = BinaryMapFn(EK) + +type state = { + maxName : int, + funcs : int EM.map, + vis : (string * int * con * exp * string) list +} + +fun exp (env, e, st) = + case e of + ERecord xes => + let + val (xes, st) = + ListUtil.foldlMap + (fn (tup as (fnam as (CName x, loc), e, xt), st) => + if x <> "Link" andalso x <> "Action" then + (tup, st) + else + let + fun needsAttention (e, _) = + case e of + ENamed f => Maybe (#2 (E.lookupENamed env f)) + | EApp (f, _) => + (case needsAttention f of + No => No + | Yes => Yes + | Maybe t => + case t of + (TFun (dom, _), _) => + if functionInside dom then + Yes + else + No + | _ => No) + | _ => No + + fun headSymbol (e, _) = + case e of + ENamed f => f + | EApp (e, _) => headSymbol e + | _ => raise Fail "Defunc: headSymbol" + + fun rtype (e, _) = + case e of + ENamed f => #2 (E.lookupENamed env f) + | EApp (f, _) => + (case rtype f of + (TFun (_, ran), _) => ran + | _ => raise Fail "Defunc: rtype [1]") + | _ => raise Fail "Defunc: rtype [2]" + in + (*Print.prefaces "Found one!" + [("e", CorePrint.p_exp env e)];*) + case needsAttention e of + Yes => + let + (*val () = print "Yes\n"*) + val f = headSymbol e + + val fvs = IS.listItems (freeVars e) + + val e = squish fvs e + val (e, t) = foldl (fn (n, (e, t)) => + let + val (x, xt) = E.lookupERel env n + in + ((EAbs (x, xt, t, e), loc), + (TFun (xt, t), loc)) + end) + (e, rtype e) fvs + + val (f', st) = + case EM.find (#funcs st, e) of + SOME f' => (f', st) + | NONE => + let + val (fx, _, _, tag) = E.lookupENamed env f + val f' = #maxName st + + val vi = (fx, f', t, e, tag) + in + (f', {maxName = f' + 1, + funcs = EM.insert (#funcs st, e, f'), + vis = vi :: #vis st}) + end + + val e = foldr (fn (n, e) => + (EApp (e, (ERel n, loc)), loc)) + (ENamed f', loc) fvs + in + (*app (fn n => Print.prefaces + "Free" + [("n", CorePrint.p_exp env (ERel n, ErrorMsg.dummySpan))]) + fvs; + Print.prefaces "Squished" + [("e", CorePrint.p_exp CoreEnv.empty e)];*) + + ((fnam, e, xt), st) + end + | _ => (tup, st) + end + | (tup, st) => (tup, st)) + st xes + in + (ERecord xes, st) + end + | _ => (e, st) + +fun bind (env, b) = + case b of + U.Decl.RelC (x, k) => E.pushCRel env x k + | U.Decl.NamedC (x, n, k, co) => E.pushCNamed env x n k co + | U.Decl.RelE (x, t) => E.pushERel env x t + | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s + +fun doDecl env = U.Decl.foldMapB {kind = fn x => x, + con = default, + exp = exp, + decl = default, + bind = bind} + env + +fun defunc file = + let + fun doDecl' (d, (env, st)) = + let + val env = E.declBinds env d + + val (d, st) = doDecl env st d + + val ds = + case #vis st of + [] => [d] + | vis => + case d of + (DValRec vis', loc) => [(DValRec (vis' @ vis), loc)] + | _ => [(DValRec vis, #2 d), d] + in + (ds, + (env, + {maxName = #maxName st, + funcs = #funcs st, + vis = []})) + end + + val (file, _) = ListUtil.foldlMapConcat doDecl' + (E.empty, + {maxName = U.File.maxName file + 1, + funcs = EM.empty, + vis = []}) + file + in + file + end + +end diff --git a/src/sources b/src/sources index 252ffe44..bddcac67 100644 --- a/src/sources +++ b/src/sources @@ -105,6 +105,9 @@ especialize.sml core_untangle.sig core_untangle.sml +defunc.sig +defunc.sml + tag.sig tag.sml -- cgit v1.2.3 From 15dbb86a5905e505527ab60972087e8bed0c9088 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 9 Nov 2008 17:27:34 -0500 Subject: Prevent overzealous Especialization --- src/defunc.sml | 5 ++- src/especialize.sml | 116 ++++++++++++++++++++++++++++------------------------ 2 files changed, 67 insertions(+), 54 deletions(-) diff --git a/src/defunc.sml b/src/defunc.sml index 8771d782..1e997983 100644 --- a/src/defunc.sml +++ b/src/defunc.sml @@ -113,7 +113,10 @@ fun exp (env, e, st) = val (xes, st) = ListUtil.foldlMap (fn (tup as (fnam as (CName x, loc), e, xt), st) => - if x <> "Link" andalso x <> "Action" then + if (x <> "Link" andalso x <> "Action") + orelse case #1 e of + ENamed _ => true + | _ => false then (tup, st) else let diff --git a/src/especialize.sml b/src/especialize.sml index d6af4e04..f9c7c388 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -135,11 +135,11 @@ fun specialize' file = fun exp (e, st : state) = let - fun getApp e = + fun getApp' e = case e of ENamed f => SOME (f, [], []) | EApp (e1, e2) => - (case getApp (#1 e1) of + (case getApp' (#1 e1) of NONE => NONE | SOME (f, xs, xs') => let @@ -154,6 +154,15 @@ fun specialize' file = | SOME k => SOME (f, xs @ [k], xs') end) | _ => NONE + + fun getApp e = + case getApp' e of + NONE => NONE + | SOME (f, xs, xs') => + if List.all (fn (ERecord [], _) => true | _ => false) xs then + SOME (f, [], xs @ xs') + else + SOME (f, xs, xs') in case getApp e of NONE => (e, st) @@ -176,6 +185,7 @@ fun specialize' file = | _ => false in if List.all (fn (ERel _, _) => false | _ => true) xs' + andalso List.exists (fn (ERecord [], _) => false | _ => true) xs' andalso not (IS.member (actionable, f)) andalso hasFunarg (typ, xs') then (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) @@ -184,57 +194,57 @@ fun specialize' file = else (e, st) end) - | SOME (f, xs, xs') => - case IM.find (#funcs st, f) of - NONE => (e, st) - | SOME {name, args, body, typ, tag} => - case KM.find (args, xs) of - SOME f' => (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) - (ENamed f', ErrorMsg.dummySpan) xs'), - st) - | NONE => - let - fun subBody (body, typ, xs) = - case (#1 body, #1 typ, xs) of - (_, _, []) => SOME (body, typ) - | (EAbs (_, _, _, body'), TFun (_, typ'), x :: xs) => - let - val body'' = E.subExpInExp (0, skeyOut x) body' - in - subBody (body'', - typ', - xs) - end - | _ => NONE - in - case subBody (body, typ, xs) of - NONE => (e, st) - | SOME (body', typ') => - let - val f' = #maxName st - val funcs = IM.insert (#funcs st, f, {name = name, - args = KM.insert (args, - xs, f'), - body = body, - typ = typ, - tag = tag}) - val st = { - maxName = f' + 1, - funcs = funcs, - decls = #decls st - } - - val (body', st) = specExp st body' - val e' = foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) - (ENamed f', ErrorMsg.dummySpan) xs' - in - (#1 e', - {maxName = #maxName st, - funcs = #funcs st, - decls = (name, f', typ', body', tag) :: #decls st}) - end - end - end + | SOME (f, xs, xs') => + case IM.find (#funcs st, f) of + NONE => (e, st) + | SOME {name, args, body, typ, tag} => + case KM.find (args, xs) of + SOME f' => (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) + (ENamed f', ErrorMsg.dummySpan) xs'), + st) + | NONE => + let + fun subBody (body, typ, xs) = + case (#1 body, #1 typ, xs) of + (_, _, []) => SOME (body, typ) + | (EAbs (_, _, _, body'), TFun (_, typ'), x :: xs) => + let + val body'' = E.subExpInExp (0, skeyOut x) body' + in + subBody (body'', + typ', + xs) + end + | _ => NONE + in + case subBody (body, typ, xs) of + NONE => (e, st) + | SOME (body', typ') => + let + val f' = #maxName st + val funcs = IM.insert (#funcs st, f, {name = name, + args = KM.insert (args, + xs, f'), + body = body, + typ = typ, + tag = tag}) + val st = { + maxName = f' + 1, + funcs = funcs, + decls = #decls st + } + + val (body', st) = specExp st body' + val e' = foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) + (ENamed f', ErrorMsg.dummySpan) xs' + in + (#1 e', + {maxName = #maxName st, + funcs = #funcs st, + decls = (name, f', typ', body', tag) :: #decls st}) + end + end + end and specExp st = U.Exp.foldMap {kind = kind, con = con, exp = exp} st -- cgit v1.2.3 From a676c53ffcf88833514d12968ee5b6b28aa8cc8a Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 9 Nov 2008 18:19:47 -0500 Subject: Remove some allocation --- src/cjr_print.sml | 15 +++++++++------ src/mono_opt.sml | 30 +++++++++++++++++++++++++++++- src/mono_reduce.sig | 2 ++ src/prepare.sml | 33 ++++++++++++++++++++++++--------- 4 files changed, 64 insertions(+), 16 deletions(-) diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 7c13fcb5..b1eb04b3 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1186,10 +1186,6 @@ 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);" @@ -1371,8 +1367,15 @@ fun p_exp' par env (e, loc) = | ENextval {seq, prepared} => let - val query = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) - val query = (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), query]), loc) + val query = case seq of + (EPrim (Prim.String s), loc) => + (EPrim (Prim.String ("SELECT NEXTVAL('" ^ s ^ "')")), loc) + | _ => + let + val query = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) + in + (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), query]), loc) + end in box [string "(uw_begin_region(ctx), ", string "({", diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 93cb888b..e350db1d 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -319,12 +319,40 @@ fun exp e = e | EWrite (EQuery {exps, tables, state, query, + initial = (EPrim (Prim.String ""), _), + body}, loc) => + let + fun passLets (depth, (e', _), lets) = + case e' of + EStrcat ((ERel x, _), e'') => + if x = depth then + let + val body = (optExp (EWrite e'', loc), loc) + val body = foldl (fn ((x, t, e'), e) => + (ELet (x, t, e', e), loc)) + body lets + in + EQuery {exps = exps, tables = tables, query = query, + state = (TRecord [], loc), + initial = (ERecord [], loc), + body = body} + end + else + e + | ELet (x, t, e', e'') => + passLets (depth + 1, e'', (x, t, e') :: lets) + | _ => e + in + passLets (0, body, []) + end + + (*| EWrite (EQuery {exps, tables, state, query, initial = (EPrim (Prim.String ""), _), body = (EStrcat ((ERel 0, _), e'), _)}, loc) => EQuery {exps = exps, tables = tables, query = query, state = (TRecord [], loc), initial = (ERecord [], loc), - body = (optExp (EWrite e', loc), loc)} + body = (optExp (EWrite e', loc), loc)}*) | EWrite (ELet (x, t, e1, e2), loc) => optExp (ELet (x, t, e1, (EWrite e2, loc)), loc) diff --git a/src/mono_reduce.sig b/src/mono_reduce.sig index 2495c7f9..a6b6cc81 100644 --- a/src/mono_reduce.sig +++ b/src/mono_reduce.sig @@ -33,4 +33,6 @@ signature MONO_REDUCE = sig val subExpInExp : int * Mono.exp -> Mono.exp -> Mono.exp + val impure : Mono.exp -> bool + end diff --git a/src/prepare.sml b/src/prepare.sml index b20c7fec..28c14639 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -176,13 +176,21 @@ fun prepExp (e as (_, loc), sns) = end | EQuery {exps, tables, rnum, state, query, body, initial, ...} => - (case prepString (query, [], 0) of - NONE => (e, sns) - | SOME (ss, n) => - ((EQuery {exps = exps, tables = tables, rnum = rnum, - state = state, query = query, body = body, - initial = initial, prepared = SOME (#2 sns)}, loc), - ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1))) + let + val (body, sns) = prepExp (body, sns) + in + case prepString (query, [], 0) of + NONE => + ((EQuery {exps = exps, tables = tables, rnum = rnum, + state = state, query = query, body = body, + initial = initial, prepared = SOME (#2 sns)}, loc), + sns) + | SOME (ss, n) => + ((EQuery {exps = exps, tables = tables, rnum = rnum, + state = state, query = query, body = body, + initial = initial, prepared = SOME (#2 sns)}, loc), + ((String.concat (rev ss), n) :: #1 sns, #2 sns + 1)) + end | EDml {dml, ...} => (case prepString (dml, [], 0) of @@ -193,8 +201,15 @@ fun prepExp (e as (_, loc), sns) = | ENextval {seq, ...} => let - val s = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) - val s = (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), s]), loc) + val s = case seq of + (EPrim (Prim.String s), loc) => + (EPrim (Prim.String ("SELECT NEXTVAL('" ^ s ^ "')")), loc) + | _ => + let + val s' = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) + in + (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), s']), loc) + end in case prepString (s, [], 0) of NONE => (e, sns) -- cgit v1.2.3 From 5ca452a8576373895301be85a7dfc13746036cac Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 11 Nov 2008 11:49:51 -0500 Subject: Get threadedBlog to work --- src/core_print.sml | 2 +- src/elab_env.sig | 1 + src/especialize.sml | 21 +++++++-- src/unnest.sml | 129 ++++++++++++++++++++++++++++++++++++---------------- 4 files changed, 111 insertions(+), 42 deletions(-) diff --git a/src/core_print.sml b/src/core_print.sml index af43e401..f209b84f 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -227,7 +227,7 @@ fun p_exp' par env (e, _) = string "(", p_list (p_exp env) es, string "))"] - | EApp (e1, e2) => parenIf par (box [p_exp env e1, + | EApp (e1, e2) => parenIf par (box [p_exp' true env e1, space, p_exp' true env e2]) | EAbs (x, t, _, e) => parenIf par (box [string "fn", diff --git a/src/elab_env.sig b/src/elab_env.sig index 926837e1..0b436106 100644 --- a/src/elab_env.sig +++ b/src/elab_env.sig @@ -30,6 +30,7 @@ signature ELAB_ENV = sig exception SynUnif val liftConInCon : int -> Elab.con -> Elab.con + val liftConInExp : int -> Elab.exp -> Elab.exp val liftExpInExp : int -> Elab.exp -> Elab.exp val subExpInExp : (int * Elab.exp) -> Elab.exp -> Elab.exp diff --git a/src/especialize.sml b/src/especialize.sml index f9c7c388..ffd4745b 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -188,9 +188,14 @@ fun specialize' file = andalso List.exists (fn (ERecord [], _) => false | _ => true) xs' andalso not (IS.member (actionable, f)) andalso hasFunarg (typ, xs') then - (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) - body xs'), - st) + let + val e = foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) + body xs' + in + (*Print.prefaces "Unfolded" + [("e", CorePrint.p_exp CoreEnv.empty e)];*) + (#1 e, st) + end else (e, st) end) @@ -221,6 +226,9 @@ fun specialize' file = NONE => (e, st) | SOME (body', typ') => let + (*val () = Print.prefaces "sub'd" + [("body'", CorePrint.p_exp CoreEnv.empty body')]*) + val f' = #maxName st val funcs = IM.insert (#funcs st, f, {name = name, args = KM.insert (args, @@ -234,7 +242,13 @@ fun specialize' file = decls = #decls st } + (*val () = print ("Created " ^ Int.toString f' ^ " from " + ^ Int.toString f ^ "\n") + val () = Print.prefaces "body'" + [("body'", CorePrint.p_exp CoreEnv.empty body')]*) val (body', st) = specExp st body' + (*val () = Print.prefaces "body''" + [("body'", CorePrint.p_exp CoreEnv.empty body')]*) val e' = foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) (ENamed f', ErrorMsg.dummySpan) xs' in @@ -316,6 +330,7 @@ fun specialize' file = fun specialize file = let + (*val () = Print.prefaces "Intermediate" [("file", CorePrint.p_file CoreEnv.empty file)];*) val (changed, file) = specialize' file in if changed then diff --git a/src/unnest.sml b/src/unnest.sml index 6a37d484..fe63f9fe 100644 --- a/src/unnest.sml +++ b/src/unnest.sml @@ -36,6 +36,35 @@ structure U = ElabUtil structure IS = IntBinarySet +fun liftExpInExp by = + U.Exp.mapB {kind = fn k => k, + con = fn _ => fn c => c, + exp = fn bound => fn e => + case e of + ERel xn => + if xn < bound then + e + else + ERel (xn + by) + | _ => e, + bind = fn (bound, U.Exp.RelE _) => bound + 1 + | (bound, _) => bound} + +val subExpInExp = + U.Exp.mapB {kind = fn k => k, + con = fn _ => fn c => c, + exp = fn (xn, rep) => fn e => + case e of + ERel xn' => + if xn' = xn then + #1 rep + else + e + | _ => e, + bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, E.liftExpInExp 0 rep) + | ((xn, rep), U.Exp.RelC _) => (xn, E.liftConInExp 0 rep) + | (ctx, _) => ctx} + val fvsCon = U.Con.foldB {kind = fn (_, st) => st, con = fn (cb, c, cvs) => case c of @@ -87,7 +116,7 @@ fun positionOf (x : int) ls = po (n + 1) ls' in po 0 ls - handle Fail _ => raise Fail ("Unnset.positionOf(" + handle Fail _ => raise Fail ("Unnest.positionOf(" ^ Int.toString x ^ ", " ^ String.concatWith ";" (map Int.toString ls) @@ -124,7 +153,7 @@ fun squishExp (nr, cfv, efv) = case e of ERel n => if n >= eb then - ERel (positionOf (n - eb) efv + eb) + ERel (positionOf (n - eb) efv + eb - nr) else e | _ => e, @@ -146,17 +175,32 @@ fun exp ((ks, ts), e as old, st : state) = case e of ELet (eds, e) => let - (*val () = Print.prefaces "let" [("e", ElabPrint.p_exp E.empty (old, ErrorMsg.dummySpan))]*) + (*val () = Print.prefaces "Letto" [("e", ElabPrint.p_exp E.empty (old, ErrorMsg.dummySpan))]*) - val doSubst = foldl (fn (p, e) => E.subExpInExp p e) + fun doSubst' (e, subs) = foldl (fn (p, e) => subExpInExp p e) e subs - val (eds, (ts, maxName, ds, subs)) = + fun doSubst (e, subs, by) = + let + val e = doSubst' (e, subs) + in + liftExpInExp (~by) (length subs) e + end + + val (eds, (ts, maxName, ds, subs, by)) = ListUtil.foldlMapConcat - (fn (ed, (ts, maxName, ds, subs)) => + (fn (ed, (ts, maxName, ds, subs, by)) => case #1 ed of - EDVal (x, t, _) => ([ed], - ((x, t) :: ts, - maxName, ds, map (fn (n, e) => (n + 1, E.liftExpInExp 0 e)) subs)) + EDVal (x, t, e) => + let + val e = doSubst (e, subs, by) + in + ([(EDVal (x, t, e), #2 ed)], + ((x, t) :: ts, + maxName, ds, + ((0, (ERel 0, #2 ed)) + :: map (fn (n, e) => (n + 1, E.liftExpInExp 0 e)) subs), + by)) + end | EDValRec vis => let val loc = #2 ed @@ -182,6 +226,7 @@ fun exp ((ks, ts), e as old, st : state) = val () = app (fn (x, t) => Print.prefaces "Var" [("x", Print.PD.string x), ("t", ElabPrint.p_con E.empty t)]) ts*) + val cfv = IS.foldl (fn (x, cfv) => let (*val () = print (Int.toString x ^ "\n")*) @@ -198,56 +243,54 @@ fun exp ((ks, ts), e as old, st : state) = maxName + 1)) maxName vis - fun apply e = - let - val e = IS.foldr (fn (x, e) => - (ECApp (e, (CRel x, loc)), loc)) - e cfv - in - IS.foldr (fn (x, e) => - (EApp (e, (ERel x, loc)), loc)) - e efv - end - val subs = map (fn (n, e) => (n + nr, E.liftExpInExp nr e)) subs + + 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 dummy = (EError, ErrorMsg.dummySpan) - - fun repeatLift k = - if k = 0 then - apply (ENamed n, loc) - else - E.liftExpInExp 0 (repeatLift (k - 1)) + val e = (ENamed n, loc) + + val e = IS.foldr (fn (x, e) => + (ECApp (e, (CRel x, loc)), loc)) + e cfv + + val e = IS.foldr (fn (x, e) => + (EApp (e, (ERel (nr + x), loc)), + loc)) + e efv in - (0, repeatLift i) + (nr - i - 1, e) end) vis - val subs' = rev subs' - val cfv = IS.listItems cfv val efv = IS.listItems efv - val efn = length efv - val subs = subs @ 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 + val e = doSubst' (e, subs) (*val () = Print.prefaces "squishCon" [("t", ElabPrint.p_con E.empty t)]*) val t = squishCon cfv t (*val () = Print.prefaces "squishExp" [("e", ElabPrint.p_exp E.empty e)]*) - val e = squishExp (0(*nr*), cfv, efv) e + val e = squishExp (nr, cfv, efv) e + (*val () = print ("Avail: " ^ Int.toString (length ts) ^ "\n")*) val (e, t) = foldl (fn (ex, (e, t)) => let + (*val () = print (Int.toString ex ^ "\n")*) val (name, t') = List.nth (ts, ex) in ((EAbs (name, @@ -258,6 +301,7 @@ fun exp ((ks, ts), e as old, st : state) = t), loc)) end) (e, t) efv + (*val () = print "Done\n"*) val (e, t) = foldl (fn (cx, (e, t)) => let @@ -274,19 +318,28 @@ fun exp ((ks, ts), e as old, st : state) = end) (e, t) cfv in + (*Print.prefaces "Have a vi" + [("x", Print.PD.string x), + ("e", ElabPrint.p_exp ElabEnv.empty e)];*) (x, n, t, e) end) vis - val ts = map (fn (x, _, t, _) => (x, t)) vis @ ts + val ts = List.revAppend (map (fn (x, _, t, _) => (x, t)) vis, ts) in - ([], (ts, maxName, vis @ ds, subs)) + ([], (ts, maxName, vis @ ds, subs, by + nr)) end) - (ts, #maxName st, #decls st, []) eds + (ts, #maxName st, #decls st, [], 0) eds + + val e' = doSubst (e, subs, by) in - (ELet (eds, doSubst e subs), + (*Print.prefaces "Before" [("e", ElabPrint.p_exp ElabEnv.empty e), + ("se", ElabPrint.p_exp ElabEnv.empty (doSubst' (e, subs))), + ("e'", ElabPrint.p_exp ElabEnv.empty e')];*) + (ELet (eds, e'), {maxName = maxName, decls = ds}) + (*(ELet (eds, doSubst (liftExpInExp (~(length subs - numRemaining)) (length subs) e) subs),*) end | _ => (e, st) -- cgit v1.2.3 From ded9f1e15308a0ed27c9892d4b0285abc25654f8 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 11 Nov 2008 15:12:24 -0500 Subject: Get preliminary ThreadedBlog working --- include/urweb.h | 2 + src/c/urweb.c | 8 ++ src/compiler.sig | 3 +- src/compiler.sml | 5 +- src/core_util.sig | 5 + src/core_util.sml | 8 ++ src/especialize.sml | 365 ++++++++++++++++++++++++++++------------------------ 7 files changed, 223 insertions(+), 173 deletions(-) diff --git a/include/urweb.h b/include/urweb.h index 7e16fd40..d148654f 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -60,6 +60,7 @@ char *uw_Basis_urlifyInt(uw_context, uw_Basis_int); char *uw_Basis_urlifyFloat(uw_context, uw_Basis_float); char *uw_Basis_urlifyString(uw_context, uw_Basis_string); char *uw_Basis_urlifyBool(uw_context, uw_Basis_bool); +char *uw_Basis_urlifyTime(uw_context, uw_Basis_time); uw_unit uw_Basis_urlifyInt_w(uw_context, uw_Basis_int); uw_unit uw_Basis_urlifyFloat_w(uw_context, uw_Basis_float); @@ -70,6 +71,7 @@ uw_Basis_int uw_Basis_unurlifyInt(uw_context, char **); uw_Basis_float uw_Basis_unurlifyFloat(uw_context, char **); uw_Basis_string uw_Basis_unurlifyString(uw_context, char **); uw_Basis_bool uw_Basis_unurlifyBool(uw_context, char **); +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); diff --git a/src/c/urweb.c b/src/c/urweb.c index 57584f53..a347dd45 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -557,6 +557,10 @@ uw_unit uw_Basis_urlifyFloat_w(uw_context ctx, uw_Basis_float n) { return uw_unit_v; } +uw_Basis_string uw_Basis_urlifyTime(uw_context ctx, uw_Basis_time t) { + return uw_Basis_urlifyInt(ctx, t); +} + uw_unit uw_Basis_urlifyString_w(uw_context ctx, uw_Basis_string s) { uw_check(ctx, strlen(s) * 3); @@ -615,6 +619,10 @@ uw_Basis_float uw_Basis_unurlifyFloat(uw_context ctx, char **s) { return r; } +uw_Basis_time uw_Basis_unurlifyTime(uw_context ctx, char **s) { + return uw_Basis_unurlifyInt(ctx, s); +} + static uw_Basis_string uw_unurlifyString_to(uw_context ctx, char *r, char *s) { char *s1, *s2; int n; diff --git a/src/compiler.sig b/src/compiler.sig index 402706be..2bed20f9 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -90,7 +90,8 @@ signature COMPILER = sig val toEspecialize : (string, Core.file) transform val toCore_untangle : (string, Core.file) transform val toShake1 : (string, Core.file) transform - val toDefunc : (string, Core.file) transform + val toDefunc : (string, Core.file) transform + val toShake1' : (string, Core.file) transform val toTag : (string, Core.file) transform val toReduce : (string, Core.file) transform val toUnpoly : (string, Core.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 93a03169..b2f8f91c 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -446,12 +446,15 @@ val defunc = { val toDefunc = transform defunc "defunc" o toShake1 +val toCore_untangle' = transform core_untangle "core_untangle'" o toDefunc +val toShake1' = transform shake "shake1'" o toCore_untangle' + val tag = { func = Tag.tag, print = CorePrint.p_file CoreEnv.empty } -val toTag = transform tag "tag" o toDefunc +val toTag = transform tag "tag" o toShake1' val reduce = { func = Reduce.reduce, diff --git a/src/core_util.sig b/src/core_util.sig index 100932c3..39f50cc1 100644 --- a/src/core_util.sig +++ b/src/core_util.sig @@ -126,6 +126,11 @@ structure Exp : sig con : Core.con' * 'state -> Core.con' * 'state, exp : Core.exp' * 'state -> Core.exp' * 'state} -> 'state -> Core.exp -> Core.exp * 'state + val foldMapB : {kind : Core.kind' * 'state -> Core.kind' * 'state, + con : 'context * Core.con' * 'state -> Core.con' * 'state, + exp : 'context * Core.exp' * 'state -> Core.exp' * 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Core.exp -> Core.exp * 'state end structure Decl : sig diff --git a/src/core_util.sml b/src/core_util.sml index f7e92f51..38004f74 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -763,6 +763,14 @@ fun foldMap {kind, con, exp} s e = S.Continue v => v | S.Return _ => raise Fail "CoreUtil.Exp.foldMap: Impossible" +fun foldMapB {kind, con, exp, bind} ctx s e = + case mapfoldB {kind = fn k => fn s => S.Continue (kind (k, s)), + con = fn ctx => fn c => fn s => S.Continue (con (ctx, c, s)), + exp = fn ctx => fn e => fn s => S.Continue (exp (ctx, e, s)), + bind = bind} ctx e s of + S.Continue v => v + | S.Return _ => raise Fail "CoreUtil.Exp.foldMapB: Impossible" + end structure Decl = struct diff --git a/src/especialize.sml b/src/especialize.sml index ffd4745b..220b48bd 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -43,47 +43,52 @@ structure KM = BinaryMapFn(K) structure IM = IntBinaryMap structure IS = IntBinarySet -val sizeOf = U.Exp.fold {kind = fn (_, n) => n, - con = fn (_, n) => n, - exp = fn (_, n) => n + 1} - 0 - -val isOpen = U.Exp.existsB {kind = fn _ => false, - con = fn ((nc, _), c) => - case c of - CRel n => n >= nc - | _ => false, - exp = fn ((_, ne), e) => +val freeVars = U.Exp.foldB {kind = fn (_, xs) => xs, + con = fn (_, _, xs) => xs, + exp = fn (bound, e, xs) => case e of - ERel n => n >= ne - | _ => false, - bind = fn ((nc, ne), b) => + ERel x => + if x >= bound then + IS.add (xs, x - bound) + else + xs + | _ => xs, + bind = fn (bound, b) => case b of - U.Exp.RelC _ => (nc + 1, ne) - | U.Exp.RelE _ => (nc, ne + 1) - | _ => (nc, ne)} - (0, 0) - -fun baseBad (e, _) = - case e of - EAbs (_, _, _, e) => sizeOf e > 20 - | ENamed _ => false - | _ => true - -fun isBad e = - case e of - (ERecord xes, _) => - length xes > 10 - orelse List.exists (fn (_, e, _) => baseBad e) xes - | _ => baseBad e - -fun skeyIn e = - if isBad e orelse isOpen e then - NONE - else - SOME e - -fun skeyOut e = e + U.Exp.RelE _ => bound + 1 + | _ => bound} + 0 IS.empty + +fun positionOf (v : int, ls) = + let + fun pof (pos, ls) = + case ls of + [] => raise Fail "Defunc.positionOf" + | v' :: ls' => + if v = v' then + pos + else + pof (pos + 1, ls') + in + pof (0, ls) + end + +fun squish fvs = + U.Exp.mapB {kind = fn k => k, + con = fn _ => fn c => c, + exp = fn bound => fn e => + case e of + ERel x => + if x >= bound then + ERel (positionOf (x - bound, fvs) + bound) + else + e + | _ => e, + bind = fn (bound, b) => + case b of + U.Exp.RelE _ => bound + 1 + | _ => bound} + 0 type func = { name : string, @@ -99,12 +104,12 @@ type state = { decls : (string * int * con * exp * string) list } -fun kind (k, st) = (k, st) -fun con (c, st) = (c, st) +fun kind x = x +fun default (_, x, st) = (x, st) fun specialize' file = let - fun default (_, fs) = fs + fun default' (_, fs) = fs fun actionableExp (e, fs) = case e of @@ -127,149 +132,159 @@ fun specialize' file = | _ => fs val actionable = - U.File.fold {kind = default, - con = default, + U.File.fold {kind = default', + con = default', exp = actionableExp, - decl = default} + decl = default'} IS.empty file - fun exp (e, st : state) = + fun bind (env, b) = + case b of + U.Decl.RelC (x, k) => E.pushCRel env x k + | U.Decl.NamedC (x, n, k, co) => E.pushCNamed env x n k co + | U.Decl.RelE (x, t) => E.pushERel env x t + | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s + + fun exp (env, e, st : state) = let - fun getApp' e = + fun getApp e = case e of - ENamed f => SOME (f, [], []) + ENamed f => SOME (f, []) | EApp (e1, e2) => - (case getApp' (#1 e1) of + (case getApp (#1 e1) of NONE => NONE - | SOME (f, xs, xs') => - let - val k = - if List.null xs' then - skeyIn e2 - else - NONE - in - case k of - NONE => SOME (f, xs, xs' @ [e2]) - | SOME k => SOME (f, xs @ [k], xs') - end) + | SOME (f, xs) => SOME (f, xs @ [e2])) | _ => NONE - - fun getApp e = - case getApp' e of - NONE => NONE - | SOME (f, xs, xs') => - if List.all (fn (ERecord [], _) => true | _ => false) xs then - SOME (f, [], xs @ xs') - else - SOME (f, xs, xs') in case getApp e of NONE => (e, st) - | SOME (f, [], []) => (e, st) - | SOME (f, [], xs') => - (case IM.find (#funcs st, f) of - NONE => (e, st) - | SOME {typ, body, ...} => - let - val functionInside = U.Con.exists {kind = fn _ => false, - con = fn TFun _ => true - | CFfi ("Basis", "transaction") => true - | _ => false} - - fun hasFunarg (t, xs) = - case (t, xs) of - ((TFun (dom, ran), _), _ :: xs) => - functionInside dom - orelse hasFunarg (ran, xs) - | _ => false - in - if List.all (fn (ERel _, _) => false | _ => true) xs' - andalso List.exists (fn (ERecord [], _) => false | _ => true) xs' - andalso not (IS.member (actionable, f)) - andalso hasFunarg (typ, xs') then - let - val e = foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) - body xs' - in - (*Print.prefaces "Unfolded" - [("e", CorePrint.p_exp CoreEnv.empty e)];*) - (#1 e, st) - end - else - (e, st) - end) - | SOME (f, xs, xs') => + | SOME (f, xs) => case IM.find (#funcs st, f) of NONE => (e, st) | SOME {name, args, body, typ, tag} => - case KM.find (args, xs) of - SOME f' => (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) - (ENamed f', ErrorMsg.dummySpan) xs'), - st) - | NONE => - let - fun subBody (body, typ, xs) = - case (#1 body, #1 typ, xs) of - (_, _, []) => SOME (body, typ) - | (EAbs (_, _, _, body'), TFun (_, typ'), x :: xs) => - let - val body'' = E.subExpInExp (0, skeyOut x) body' - in - subBody (body'', - typ', - xs) - end - | _ => NONE - in - case subBody (body, typ, xs) of - NONE => (e, st) - | SOME (body', typ') => + let + val functionInside = U.Con.exists {kind = fn _ => false, + con = fn TFun _ => true + | CFfi ("Basis", "transaction") => true + | _ => false} + val loc = ErrorMsg.dummySpan + + fun findSplit (xs, typ, fxs, fvs) = + case (#1 typ, xs) of + (TFun (dom, ran), e :: xs') => + if functionInside dom then + findSplit (xs', + ran, + e :: fxs, + IS.union (fvs, freeVars e)) + else + (rev fxs, xs, fvs) + | _ => (rev fxs, xs, fvs) + + val (fxs, xs, fvs) = findSplit (xs, typ, [], IS.empty) + + val fxs' = map (squish (IS.listItems fvs)) fxs + + fun firstRel () = + case fxs' of + (ERel _, _) :: _ => true + | _ => false + in + if firstRel () + orelse List.all (fn (ERel _, _) => true + | _ => false) fxs' then + (e, st) + else + case KM.find (args, fxs') of + SOME f' => + let + val e = (ENamed f', loc) + val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc)) + e fvs + val e = foldl (fn (arg, e) => (EApp (e, arg), loc)) + e xs + in + (*Print.prefaces "Brand new (reuse)" + [("e'", CorePrint.p_exp env e)];*) + (#1 e, st) + end + | NONE => let - (*val () = Print.prefaces "sub'd" - [("body'", CorePrint.p_exp CoreEnv.empty body')]*) - - val f' = #maxName st - val funcs = IM.insert (#funcs st, f, {name = name, - args = KM.insert (args, - xs, f'), - body = body, - typ = typ, - tag = tag}) - val st = { - maxName = f' + 1, - funcs = funcs, - decls = #decls st - } - - (*val () = print ("Created " ^ Int.toString f' ^ " from " - ^ Int.toString f ^ "\n") - val () = Print.prefaces "body'" - [("body'", CorePrint.p_exp CoreEnv.empty body')]*) - val (body', st) = specExp st body' - (*val () = Print.prefaces "body''" - [("body'", CorePrint.p_exp CoreEnv.empty body')]*) - val e' = foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) - (ENamed f', ErrorMsg.dummySpan) xs' + fun subBody (body, typ, fxs') = + case (#1 body, #1 typ, fxs') of + (_, _, []) => SOME (body, typ) + | (EAbs (_, _, _, body'), TFun (_, typ'), x :: fxs'') => + let + val body'' = E.subExpInExp (0, x) body' + in + subBody (body'', + typ', + fxs'') + end + | _ => NONE in - (#1 e', - {maxName = #maxName st, - funcs = #funcs st, - decls = (name, f', typ', body', tag) :: #decls st}) + case subBody (body, typ, fxs') of + NONE => (e, st) + | SOME (body', typ') => + let + val f' = #maxName st + val args = KM.insert (args, fxs', f') + val funcs = IM.insert (#funcs st, f, {name = name, + args = args, + body = body, + typ = typ, + tag = tag}) + val st = { + maxName = f' + 1, + funcs = funcs, + decls = #decls st + } + + (*val () = Print.prefaces "specExp" + [("f", CorePrint.p_exp env (ENamed f, loc)), + ("f'", CorePrint.p_exp env (ENamed f', loc)), + ("xs", Print.p_list (CorePrint.p_exp env) xs), + ("fxs'", Print.p_list + (CorePrint.p_exp E.empty) fxs'), + ("e", CorePrint.p_exp env (e, loc))]*) + val (body', typ') = IS.foldl (fn (n, (body', typ')) => + let + val (x, xt) = E.lookupERel env n + in + ((EAbs (x, xt, typ', body'), + loc), + (TFun (xt, typ'), loc)) + end) + (body', typ') fvs + val (body', st) = specExp env st body' + + val e' = (ENamed f', loc) + val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc)) + e' fvs + val e' = foldl (fn (arg, e) => (EApp (e, arg), loc)) + e' xs + (*val () = Print.prefaces "Brand new" + [("e'", CorePrint.p_exp env e'), + ("e", CorePrint.p_exp env (e, loc)), + ("body'", CorePrint.p_exp env body')]*) + in + (#1 e', + {maxName = #maxName st, + funcs = #funcs st, + decls = (name, f', typ', body', tag) :: #decls st}) + end end - end + end end - and specExp st = U.Exp.foldMap {kind = kind, con = con, exp = exp} st + and specExp env = U.Exp.foldMapB {kind = kind, con = default, exp = exp, bind = bind} env - fun decl (d, st) = (d, st) + val specDecl = U.Decl.foldMapB {kind = kind, con = default, exp = exp, decl = default, bind = bind} - val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl} - - - - fun doDecl (d, (st : state, changed)) = + fun doDecl (d, (env, st : state, changed)) = let + val env = E.declBinds env d + val funcs = #funcs st val funcs = case #1 d of @@ -288,7 +303,7 @@ fun specialize' file = decls = []} (*val () = Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)]*) - val (d', st) = specDecl st d + val (d', st) = specDecl env st d (*val () = print "/decl\n"*) val funcs = #funcs st @@ -314,16 +329,19 @@ fun specialize' file = (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)] | _ => [(DValRec vis, ErrorMsg.dummySpan), d']) in - (ds, ({maxName = #maxName st, + (ds, (env, + {maxName = #maxName st, funcs = funcs, decls = []}, changed)) end - val (ds, (_, changed)) = ListUtil.foldlMapConcat doDecl - ({maxName = U.File.maxName file + 1, - funcs = IM.empty, - decls = []}, false) - file + val (ds, (_, _, changed)) = ListUtil.foldlMapConcat doDecl + (E.empty, + {maxName = U.File.maxName file + 1, + funcs = IM.empty, + decls = []}, + false) + file in (changed, ds) end @@ -331,10 +349,15 @@ fun specialize' file = fun specialize file = let (*val () = Print.prefaces "Intermediate" [("file", CorePrint.p_file CoreEnv.empty file)];*) + val file = ReduceLocal.reduce file val (changed, file) = specialize' file + val file = ReduceLocal.reduce file + (*val file = CoreUntangle.untangle file + val file = Shake.shake file*) in + (*print "Round over\n";*) if changed then - specialize (ReduceLocal.reduce file) + specialize file else file end -- cgit v1.2.3 From cb961c521e9aee367e2d8f3ede63bcf191c53f05 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 11 Nov 2008 15:32:10 -0500 Subject: Ignore UseRel effects in [let] expansions --- src/mono_reduce.sml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 942a9291..24e686da 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -425,12 +425,13 @@ fun reduce file = if impure e' then let val effs_e' = summarize 0 e' + val effs_e' = List.filter (fn x => x <> UseRel) effs_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)]*) + [("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 -- 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(-) 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 16c1bacfe1116391bb7b9a459e7ad53930f2719b Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 11 Nov 2008 16:51:45 -0500 Subject: Fix demo regression --- src/cjr_print.sml | 7 ++++++- src/prepare.sml | 2 +- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/src/cjr_print.sml b/src/cjr_print.sml index b1eb04b3..cb88ca84 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -476,7 +476,12 @@ fun getPargs (e, _) = | EFfiApp ("Basis", "sqlifyBoolN", [e]) => [(e, Nullable Bool)] | EFfiApp ("Basis", "sqlifyTimeN", [e]) => [(e, Nullable Time)] - | ECase (e, _, _) => [(e, Bool)] + | ECase (e, + [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), + (EPrim (Prim.String "TRUE"), _)), + ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _), + (EPrim (Prim.String "FALSE"), _))], + _) => [(e, Bool)] | _ => raise Fail "CjrPrint: getPargs" diff --git a/src/prepare.sml b/src/prepare.sml index 28c14639..708bcade 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -183,7 +183,7 @@ fun prepExp (e as (_, loc), sns) = NONE => ((EQuery {exps = exps, tables = tables, rnum = rnum, state = state, query = query, body = body, - initial = initial, prepared = SOME (#2 sns)}, loc), + initial = initial, prepared = NONE}, loc), sns) | SOME (ss, n) => ((EQuery {exps = exps, tables = tables, rnum = rnum, -- cgit v1.2.3 From f3e4bff668d3be5fcc7a2f6d04b7d9efb8f10624 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 11 Nov 2008 18:39:38 -0500 Subject: Handle nullary transaction pages; avoid marking up headers array when reading cookies --- src/cjr_print.sml | 4 ++-- src/tag.sml | 9 +++++---- 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/src/cjr_print.sml b/src/cjr_print.sml index cb88ca84..1c750b33 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1481,9 +1481,9 @@ fun p_exp' par env (e, loc) = in box [string "({", newline, - string "uw_Basis_string request = ", + string "uw_Basis_string request = uw_Basis_strdup(ctx, ", p_exp env e, - string ";", + string ");", newline, newline, string "(request ? ", diff --git a/src/tag.sml b/src/tag.sml index b19a0544..715da9ed 100644 --- a/src/tag.sml +++ b/src/tag.sml @@ -184,6 +184,8 @@ fun tag file = val newDs = map (fn (ek, f, cn) => let + val unit = (TRecord (CRecord ((KType, loc), []), loc), loc) + fun unravel (all as (t, _)) = case t of TFun (dom, ran) => @@ -197,15 +199,14 @@ fun tag file = val (fnam, t, _, tag) = E.lookupENamed env f val (args, result) = unravel t - val unit = (TRecord (CRecord ((KType, loc), []), loc), loc) - val (abs, t) = case args of [] => let - val body = (EWrite (ENamed f, loc), loc) + val app = (EApp ((ENamed f, loc), (ERecord [], loc)), loc) + val body = (EWrite app, loc) in - ((EAbs ("x", unit, unit, body), loc), + (body, (TFun (unit, unit), loc)) end | _ => -- 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 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 8d6ea0f475b6a47a2f1072897b226d51648eb3f7 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 11 Nov 2008 19:58:25 -0500 Subject: Map distributivity rule in hnormCon --- src/elab_ops.sml | 50 ++++++++++++++++++++++++++++++++++++++++++-------- src/elab_print.sml | 2 +- 2 files changed, 43 insertions(+), 9 deletions(-) diff --git a/src/elab_ops.sml b/src/elab_ops.sml index 95ad971f..5102d0ab 100644 --- a/src/elab_ops.sml +++ b/src/elab_ops.sml @@ -150,6 +150,39 @@ fun hnormCon env (cAll as (c, loc)) = | c => c val c = unconstraint c + fun tryDistributivity () = + let + fun distribute (c1, c2) = + let + val c = (CFold ks, loc) + val c = (CApp (c, f), loc) + val c = (CApp (c, i), loc) + + val c1 = (CApp (c, c1), loc) + val c2 = (CApp (c, c2), loc) + val c = (CConcat (c1, c2), loc) + in + hnormCon env c + end + in + case (hnormCon env i, hnormCon env c2, hnormCon env c) of + ((CRecord (_, []), _), + (CConcat (arg1, arg2), _), + (CConcat (c1, c2'), _)) => + (case (hnormCon env c1, hnormCon env c2') of + ((CRecord (_, [(nm', v')]), _), + (CUnif (_, _, _, rR'), _)) => + (case hnormCon env nm' of + (CUnif (_, _, _, nmR'), _) => + if nmR' = nmR andalso rR' = rR then + distribute (arg1, arg2) + else + default () + | _ => default ()) + | _ => default ()) + | _ => default () + end + fun tryFusion () = let fun fuse (dom, new_v, r') = @@ -205,16 +238,17 @@ fun hnormCon env (cAll as (c, loc)) = rR := SOME (CError, loc); fuse (dom, v', r')) else - default () - | _ => default ()) - | _ => default ()) - | _ => default () + tryDistributivity () + | _ => tryDistributivity ()) + | _ => tryDistributivity ()) + | _ => tryDistributivity () end - | _ => default ()) - | _ => default ()) - | _ => default ()) - | _ => default () + | _ => tryDistributivity ()) + | _ => tryDistributivity ()) + | _ => tryDistributivity ()) + | _ => tryDistributivity () end + in (*Print.prefaces "Consider" [("c", ElabPrint.p_con env c)];*) case (hnormCon env i, unconstraint c) of diff --git a/src/elab_print.sml b/src/elab_print.sml index 62b1ea02..2f652737 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -335,7 +335,7 @@ fun p_exp' par env (e, _) = else box [p_exp' true env e1, space, - string "with", + string "++", space, p_exp' true env e2]) | ECut (e, c, {field, rest}) => -- cgit v1.2.3 From 0510db82b18aae60ca4e9f5935ad0f18e0b1a1ea Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 11 Nov 2008 20:24:55 -0500 Subject: Fix type calculation for applying-a-case optimization --- src/mono_opt.sml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/mono_opt.sml b/src/mono_opt.sml index e350db1d..b56372c7 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -292,7 +292,7 @@ fun exp e = {disc = disc, result = (TRecord [], loc)}), loc) - | EApp ((ECase (discE, pes, {disc, ...}), loc), arg as (ERecord [], _)) => + | EApp ((ECase (discE, pes, {disc, result = (TFun (_, ran), _)}), loc), arg as (ERecord [], _)) => let fun doBody e = case #1 e of @@ -302,7 +302,7 @@ fun exp e = optExp (ECase (discE, map (fn (p, e) => (p, doBody e)) pes, {disc = disc, - result = (TRecord [], loc)}), loc) + result = ran}), loc) end | EWrite (EQuery {exps, tables, state, query, -- cgit v1.2.3 From 68efe8d483e8d1e9f138c1388f737aa0ab68ace8 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 18 Nov 2008 13:27:33 -0500 Subject: Mention Especialize in CHANGELOG --- CHANGELOG | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG b/CHANGELOG index 0f8d0f09..3bc58f47 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -6,6 +6,7 @@ NEXT - Primitive "time" type - Nullable SQL columns (via "option") - Cookies +- Compiler: Specialization of functions to known arguments (especially of function type) ======== 20081028 -- cgit v1.2.3 From 398bf05eb87aa7e4a5ece16c938719325eb304d8 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 18 Nov 2008 13:28:44 -0500 Subject: Tag CHANGELOG with release number --- CHANGELOG | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/CHANGELOG b/CHANGELOG index 3bc58f47..4ce8e4c2 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,5 +1,5 @@ ======== -NEXT +20081118 ======== - Nested function definitions -- cgit v1.2.3 From 09ced0a87d9c57caaf4a832f2547f366fd6e53bd Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 18 Nov 2008 13:47:23 -0500 Subject: Extend prose about server .exes --- demo/prose | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/demo/prose b/demo/prose index 11661211..35e93a9a 100644 --- a/demo/prose +++ b/demo/prose @@ -13,7 +13,7 @@ urweb -demo /Demo demo

    urweb demo/hello
    -to build the "Hello World" demo application. Whether building the pieces separately or all at once with the -demo flag, a standalone web server executable is generated. The -demo command line will generate demo/demo.exe, and the other command line will generate demo/hello.exe. Either can be run with a single argument, an integer specifying how many request handler pthreads to spawn. The server accepts requests on port 8080.

    +to build the "Hello World" demo application. Whether building the pieces separately or all at once with the -demo flag, a standalone web server executable is generated. The -demo command line will generate demo/demo.exe, and the other command line will generate demo/hello.exe. Either can be run with no arguments to start a single-threaded server accepting requests on port 8080. Pass the flag -h to see which options are available.

    The -demo version also generates some HTML in a subdirectory out of the demo directory. It is easy to set Apache up to serve these HTML files, and to proxy out to the Ur/Web web server for dynamic page requests. This configuration works for me, where DIR is the location of an Ur/Web source distribution. -- cgit v1.2.3 From 3bbe239dcdcb4ef91dd35ccf369160e103d04f56 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 20 Nov 2008 10:41:58 -0500 Subject: Update Crud demo to use local functions --- demo/crud.ur | 109 +++++++++++++++++++++++++++++++---------------------------- 1 file changed, 57 insertions(+), 52 deletions(-) diff --git a/demo/crud.ur b/demo/crud.ur index a120cb2a..a3ad59d1 100644 --- a/demo/crud.ur +++ b/demo/crud.ur @@ -110,59 +110,64 @@ functor Make(M : sig {ls} - and save (id : int) (inputs : $(mapT2T sndTT M.cols)) = - dml (update [mapT2T fstTT M.cols] - (foldT2R2 [sndTT] [colMeta] - [fn cols => $(mapT2T (fn t :: (Type * Type) => - sql_exp [T = [Id = int] - ++ mapT2T fstTT M.cols] - [] [] t.1) cols)] - (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) - [[nm] ~ rest] => - fn input col acc => acc ++ {nm = - @sql_inject col.Inject (col.Parse input)}) - {} [M.cols] inputs M.cols) - tab (WHERE T.Id = {[id]})); - ls <- list (); - return -

    Saved!

    - - {ls} -     - and upd (id : int) = - 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
    - {foldT2R2 [fstTT] [colMeta] [fn cols :: {(Type * Type)} => xml form [] (mapT2T sndTT cols)] - (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) - [[nm] ~ rest] (v : t.1) (col : colMeta t) - (acc : xml form [] (mapT2T sndTT rest)) => - -
  • {cdata col.Nam}: {col.WidgetPopulated [nm] v}
    • - {useMore acc} -     ) - - [M.cols] fs.Tab M.cols} - - -
    - - and delete (id : int) = - dml (DELETE FROM tab WHERE Id = {[id]}); - ls <- list (); - return -

    The deed is done.

    - - {ls} -     - - and confirm (id : int) = return -

    Are you sure you want to delete ID #{[id]}?

    - -

    I was born sure!

    -     + let + fun save (inputs : $(mapT2T sndTT M.cols)) = + dml (update [mapT2T fstTT M.cols] + (foldT2R2 [sndTT] [colMeta] + [fn cols => $(mapT2T (fn t :: (Type * Type) => + sql_exp [T = [Id = int] + ++ mapT2T fstTT M.cols] + [] [] t.1) cols)] + (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) + [[nm] ~ rest] => + fn input col acc => acc ++ {nm = + @sql_inject col.Inject (col.Parse input)}) + {} [M.cols] inputs M.cols) + tab (WHERE T.Id = {[id]})); + ls <- list (); + return +

    Saved!

    + + {ls} +     + in + 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
    + {foldT2R2 [fstTT] [colMeta] [fn cols :: {(Type * Type)} => xml form [] (mapT2T sndTT cols)] + (fn (nm :: Name) (t :: (Type * Type)) (rest :: {(Type * Type)}) + [[nm] ~ rest] (v : t.1) (col : colMeta t) + (acc : xml form [] (mapT2T sndTT rest)) => + +
  • {cdata col.Nam}: {col.WidgetPopulated [nm] v}
    • + {useMore acc} +     ) + + [M.cols] fs.Tab M.cols} + + +
    + end + + and confirm (id : int) = + let + fun delete () = + dml (DELETE FROM tab WHERE Id = {[id]}); + ls <- list (); + return +

    The deed is done.

    + + {ls} +     + in + return +

    Are you sure you want to delete ID #{[id]}?

    + +

    I was born sure!

    +     + end and main () = ls <- list (); -- cgit v1.2.3 From 7b09fa2aca2982038889f960e51d7b1e91a70991 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 20 Nov 2008 10:44:28 -0500 Subject: Fix missing initial after restarts --- src/c/driver.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/c/driver.c b/src/c/driver.c index 49537614..f80361b1 100644 --- a/src/c/driver.c +++ b/src/c/driver.c @@ -189,9 +189,10 @@ static void *worker(void *data) { printf("Serving URI %s....\n", path); uw_set_headers(ctx, headers); - uw_write(ctx, ""); while (1) { + uw_write(ctx, ""); + if (uw_db_begin(ctx)) { printf("Error running SQL BEGIN\n"); if (retries_left) -- cgit v1.2.3 From a01f4dd530689d29ac7518bb9a8d19b919ef76ac Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 20 Nov 2008 11:34:36 -0500 Subject: Some demo improvements --- demo/list.ur | 30 ++++++++++++++++++------------ demo/listFun.ur | 31 +++++++++++++++++-------------- demo/prose | 10 +++++----- demo/refFun.ur | 4 ++-- src/demo.sig | 2 +- src/demo.sml | 9 +++++++-- src/main.mlton.sml | 8 +++++--- 7 files changed, 55 insertions(+), 39 deletions(-) diff --git a/demo/list.ur b/demo/list.ur index c2dfce22..107bf92c 100644 --- a/demo/list.ur +++ b/demo/list.ur @@ -1,15 +1,21 @@ datatype list t = Nil | Cons of t * list t -fun length' (t ::: Type) (ls : list t) (acc : int) = - case ls of - Nil => acc - | Cons (_, ls') => length' ls' (acc + 1) +fun length (t ::: Type) (ls : list t) = + let + fun length' (ls : list t) (acc : int) = + case ls of + Nil => acc + | Cons (_, ls') => length' ls' (acc + 1) + in + length' ls 0 + end -fun length (t ::: Type) (ls : list t) = length' ls 0 - -fun rev' (t ::: Type) (ls : list t) (acc : list t) = - case ls of - Nil => acc - | Cons (x, ls') => rev' ls' (Cons (x, acc)) - -fun rev (t ::: Type) (ls : list t) = rev' ls Nil +fun rev (t ::: Type) (ls : list t) = + let + fun rev' (ls : list t) (acc : list t) = + case ls of + Nil => acc + | Cons (x, ls') => rev' ls' (Cons (x, acc)) + in + rev' ls Nil + end diff --git a/demo/listFun.ur b/demo/listFun.ur index c281a07d..d679c2fb 100644 --- a/demo/listFun.ur +++ b/demo/listFun.ur @@ -10,21 +10,24 @@ functor Make(M : sig Nil => [] | Cons (x, ls') => {[M.toString x]} :: {toXml ls'} - fun console (ls : list M.t) = return - Current list: {toXml ls}
    - Reversed list: {toXml (rev ls)}
    - Length: {[length ls]}
    -
    + fun console (ls : list M.t) = + let + fun cons (r : {X : string}) = + case M.fromString r.X of + None => return Invalid string! + | Some v => console (Cons (v, ls)) + in + return + Current list: {toXml ls}
    + Reversed list: {toXml (rev ls)}
    + Length: {[length ls]}
    +
    -
    - Add element: - -
    - - and cons (ls : list M.t) (r : {X : string}) = - case M.fromString r.X of - None => return Invalid string! - | Some v => console (Cons (v, ls)) +
    + Add element: + +
    + end fun main () = console Nil end diff --git a/demo/prose b/demo/prose index 35e93a9a..7d4877c0 100644 --- a/demo/prose +++ b/demo/prose @@ -1,4 +1,4 @@ -

    Ur/Web is a domain-specific language for programming web applications backed by SQL databases. It is (strongly) statically-typed (like ML and Haskell) and purely functional (like Haskell). Ur is the base language, and the web-specific features of Ur/Web (mostly) come only in the form of special rules for parsing, type inference, and optimization. The Ur core looks a lot like Standard ML, with a few Haskell-isms added, and kinder, gentler versions added of many features from dependently-typed languages like the logic behind Coq. The type system is much more expressive than in ML and Haskell, such that well-typed web applications cannot "go wrong," not just in handling single HTTP requests, but across their entire lifetimes of interacting with HTTP clients. Beyond that, Ur is unusual is using ideas from dependent typing to enable very effective metaprogramming, or programming with explicit analysis of type structure. Many common web application components can be built by Ur/Web functions that operate on types, where it seems impossible to achieve similar code re-use in more established languages.

    +

    Ur/Web is a domain-specific language for programming web applications backed by SQL databases. It is (strongly) statically-typed (like ML and Haskell) and purely functional (like Haskell). Ur is the base language, and the web-specific features of Ur/Web (mostly) come only in the form of special rules for parsing and optimization. The Ur core looks a lot like Standard ML, with a few Haskell-isms added, and kinder, gentler versions added of many features from dependently-typed languages like the logic behind Coq. The type system is much more expressive than in ML and Haskell, such that well-typed web applications cannot "go wrong," not just in handling single HTTP requests, but across their entire lifetimes of interacting with HTTP clients. Beyond that, Ur is unusual is using ideas from dependent typing to enable very effective metaprogramming, or programming with explicit analysis of type structure. Many common web application components can be built by Ur/Web functions that operate on types, where it seems impossible to achieve similar code re-use in more established languages.

    This demo is built automatically from Ur/Web sources and supporting files. If you unpack the Ur/Web source distribution, then the following steps will build you a local version of this demo: @@ -92,6 +92,10 @@ ref.urp

    The functor creates a new encapsulated SQL sequence and table on each call. These local relations show up in the automatically-generated SQL file that should be run to prepare the database for use, but they are invisible from client code. We could change the functor to create different SQL relations, without needing to change client code.

    +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.

    + sum.urp

    Metaprogramming is one of the most important facilities of Ur. This example shows how to write a function that is able to sum up the fields of records of integers, no matter which set of fields the particular record has.

    @@ -132,10 +136,6 @@ 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 e523bac7..c6a4ea5f 100644 --- a/demo/refFun.ur +++ b/demo/refFun.ur @@ -15,9 +15,9 @@ functor Make(M : sig fun read r = o <- oneOrNoRows (SELECT t.Data FROM t WHERE t.Id = {[r]}); - return (case o of + case o of None => error You already deleted that ref! - | Some r => r.T.Data) + | Some r => return r.T.Data fun write r d = dml (UPDATE t SET Data = {[d]} WHERE Id = {[r]}) diff --git a/src/demo.sig b/src/demo.sig index 17959000..4bb4a19e 100644 --- a/src/demo.sig +++ b/src/demo.sig @@ -27,6 +27,6 @@ signature DEMO = sig - val make : {prefix : string, dirname : string} -> unit + val make : {prefix : string, dirname : string, guided : bool} -> unit end diff --git a/src/demo.sml b/src/demo.sml index 5ed9da2a..580cd21f 100644 --- a/src/demo.sml +++ b/src/demo.sml @@ -27,7 +27,7 @@ structure Demo :> DEMO = struct -fun make {prefix, dirname} = +fun make {prefix, dirname, guided} = let val prose = OS.Path.joinDirFile {dir = dirname, file = "prose"} @@ -127,7 +127,12 @@ fun make {prefix, dirname} = file = out} val out = TextIO.openOut out - val () = (TextIO.output (out, "\n"); + val () = (TextIO.output (out, "\n"); TextIO.output (out, " (timing, demo, rev sources) | "-demo" :: prefix :: rest => - doArgs (rest, (timing, SOME prefix, sources)) + doArgs (rest, (timing, SOME (prefix, false), sources)) + | "-guided-demo" :: prefix :: rest => + doArgs (rest, (timing, SOME (prefix, true), sources)) | arg :: rest => let val acc = @@ -52,8 +54,8 @@ val job = val () = case demo of - SOME prefix => - Demo.make {prefix = prefix, dirname = job} + SOME (prefix, guided) => + Demo.make {prefix = prefix, dirname = job, guided = guided} | NONE => if timing then Compiler.time Compiler.toCjrize job -- cgit v1.2.3 From 0363434b9bbdea2e3ab9c432036941c0557ab62c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 20 Nov 2008 12:16:30 -0500 Subject: Profiling support --- Makefile.in | 4 ++-- src/c/driver.c | 11 ++++++++++- src/compiler.sig | 5 +++-- src/compiler.sml | 43 ++++++++++++++++++++++++++++--------------- src/demo.sml | 3 ++- 5 files changed, 45 insertions(+), 21 deletions(-) diff --git a/Makefile.in b/Makefile.in index 364b230f..ff1f4b6a 100644 --- a/Makefile.in +++ b/Makefile.in @@ -21,10 +21,10 @@ clean: rm -rf .cm src/.cm clib/urweb.o: src/c/urweb.c - gcc -O3 -I include -c src/c/urweb.c -o clib/urweb.o + gcc -O3 -I include -c src/c/urweb.c -o clib/urweb.o $(CFLAGS) clib/driver.o: src/c/driver.c - gcc -O3 -I include -c src/c/driver.c -o clib/driver.o + gcc -O3 -I include -c src/c/driver.c -o clib/driver.o $(CFLAGS) src/urweb.cm: src/prefix.cm src/sources cat src/prefix.cm src/sources \ diff --git a/src/c/driver.c b/src/c/driver.c index f80361b1..ce0d194e 100644 --- a/src/c/driver.c +++ b/src/c/driver.c @@ -1,10 +1,12 @@ #include #include +#include #include #include #include #include +#include #include @@ -297,6 +299,11 @@ static void help(char *cmd) { printf("Usage: %s [-p ] [-t ]\n", cmd); } +static void sigint(int signum) { + printf("Exiting....\n"); + exit(0); +} + int main(int argc, char *argv[]) { // The skeleton for this function comes from Beej's sockets tutorial. int sockfd; // listen on sock_fd @@ -304,7 +311,9 @@ int main(int argc, char *argv[]) { struct sockaddr_in their_addr; // connector's address information int sin_size, yes = 1; int uw_port = 8080, nthreads = 1, i, *names, opt; - + + signal(SIGINT, sigint); + while ((opt = getopt(argc, argv, "hp:t:")) != -1) { switch (opt) { case '?': diff --git a/src/compiler.sig b/src/compiler.sig index 2bed20f9..af086675 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -35,10 +35,11 @@ signature COMPILER = sig sources : string list, exe : string, sql : string option, - debug : bool + debug : bool, + profile : bool } val compile : string -> unit - val compileC : {cname : string, oname : string, ename : string, libs : string} -> unit + val compileC : {cname : string, oname : string, ename : string, libs : string, profile : bool} -> unit type ('src, 'dst) phase type ('src, 'dst) transform diff --git a/src/compiler.sml b/src/compiler.sml index b2f8f91c..6a6c4391 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -41,7 +41,8 @@ type job = { sources : string list, exe : string, sql : string option, - debug : bool + debug : bool, + profile : bool } type ('src, 'dst) phase = { @@ -199,7 +200,7 @@ val parseUr = { handle LrParser.ParseError => [], print = SourcePrint.p_file} -fun p_job {prefix, database, exe, sql, sources, debug} = +fun p_job {prefix, database, exe, sql, sources, debug, profile} = let open Print.PD open Print @@ -208,6 +209,10 @@ fun p_job {prefix, database, exe, sql, sources, debug} = box [string "DEBUG", newline] else box [], + if profile then + box [string "PROFILE", newline] + else + box [], case database of NONE => string "No database." | SOME db => string ("Database: " ^ db), @@ -260,19 +265,20 @@ val parseUrp = { readSources acc end - fun finish (prefix, database, exe, sql, debug, sources) = + fun finish (prefix, database, exe, sql, debug, profile, sources) = {prefix = Option.getOpt (prefix, "/"), database = database, exe = Option.getOpt (exe, OS.Path.joinBaseExt {base = OS.Path.base filename, ext = SOME "exe"}), sql = sql, debug = debug, + profile = profile, sources = sources} - fun read (prefix, database, exe, sql, debug) = + fun read (prefix, database, exe, sql, debug, profile) = case TextIO.inputLine inf of - NONE => finish (prefix, database, exe, sql, debug, []) - | SOME "\n" => finish (prefix, database, exe, sql, debug, readSources []) + NONE => finish (prefix, database, exe, sql, debug, profile, []) + | SOME "\n" => finish (prefix, database, exe, sql, debug, profile, readSources []) | SOME line => let val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line) @@ -284,28 +290,29 @@ val parseUrp = { (case prefix of NONE => () | SOME _ => ErrorMsg.error "Duplicate 'prefix' directive"; - read (SOME arg, database, exe, sql, debug)) + read (SOME arg, database, exe, sql, debug, profile)) | "database" => (case database of NONE => () | SOME _ => ErrorMsg.error "Duplicate 'database' directive"; - read (prefix, SOME arg, exe, sql, debug)) + read (prefix, SOME arg, exe, sql, debug, profile)) | "exe" => (case exe of NONE => () | SOME _ => ErrorMsg.error "Duplicate 'exe' directive"; - read (prefix, database, SOME (relify arg), sql, debug)) + read (prefix, database, SOME (relify arg), sql, debug, profile)) | "sql" => (case sql of NONE => () | SOME _ => ErrorMsg.error "Duplicate 'sql' directive"; - read (prefix, database, exe, SOME (relify arg), debug)) - | "debug" => read (prefix, database, exe, sql, true) + read (prefix, database, exe, SOME (relify arg), debug, profile)) + | "debug" => read (prefix, database, exe, sql, true, profile) + | "profile" => read (prefix, database, exe, sql, debug, true) | _ => (ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); - read (prefix, database, exe, sql, debug)) + read (prefix, database, exe, sql, debug, profile)) end - val job = read (NONE, NONE, NONE, NONE, false) + val job = read (NONE, NONE, NONE, NONE, false, false) in TextIO.closeIn inf; Monoize.urlPrefix := #prefix job; @@ -544,13 +551,19 @@ val sqlify = { val toSqlify = transform sqlify "sqlify" o toMono_opt2 -fun compileC {cname, oname, ename, libs} = +fun compileC {cname, oname, ename, libs, profile} = let val urweb_o = clibFile "urweb.o" val driver_o = clibFile "driver.o" val compile = "gcc " ^ Config.gccArgs ^ " -Wstrict-prototypes -Werror -O3 -I include -c " ^ cname ^ " -o " ^ oname val link = "gcc -Werror -O3 -lm -pthread " ^ libs ^ " " ^ urweb_o ^ " " ^ oname ^ " " ^ driver_o ^ " -o " ^ ename + + val (compile, link) = + if profile then + (compile ^ " -pg", link ^ " -pg") + else + (compile, link) in if not (OS.Process.isSuccess (OS.Process.system compile)) then print "C compilation failed\n" @@ -615,7 +628,7 @@ fun compile job = TextIO.closeOut outf end; - compileC {cname = cname, oname = oname, ename = ename, libs = libs}; + compileC {cname = cname, oname = oname, ename = ename, libs = libs, profile = #profile job}; cleanup () end diff --git a/src/demo.sml b/src/demo.sml index 580cd21f..4f0cb52e 100644 --- a/src/demo.sml +++ b/src/demo.sml @@ -92,7 +92,8 @@ fun make {prefix, dirname, guided} = file = "demo.exe"}, sql = SOME (OS.Path.joinDirFile {dir = dirname, file = "demo.sql"}), - debug = false + debug = false, + profile = false } val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp") -- cgit v1.2.3 From 1118c6d17278bdcd3b5e388267d4b3eafd78de51 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 20 Nov 2008 13:54:03 -0500 Subject: Fixing demo prose --- demo/prose | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/demo/prose b/demo/prose index 7d4877c0..29c12c38 100644 --- a/demo/prose +++ b/demo/prose @@ -32,7 +32,7 @@ hello.urp

    The project file justs list one filename prefix, hello. This causes both hello.urs and hello.ur to be pulled into the project. .urs files are like OCaml .mli files, and .ur files are like OCaml .ml files. That is, .urs files provide interfaces, and .ur files provide implementations. .urs files may be omitted for .ur files, in which case most permissive interfaces are inferred.

    -

    Ur/Web features a module system very similar to those found in SML and OCaml. Like in OCaml, interface files are treated as module system signatures, and they are ascribed to structures built from interface files. hello.urs tells us that we only export a function named main, taking no arguments and running a transaction that results in an HTML page. transaction is a monad in the spirit of the Haskell IO monad, with the intent that every operation performable in transaction can be undone. By design, Ur/Web does not provide a less constrained way of running side-effecting actions. This particular example application will employ no side effects, but the compiler requires that all pages be generated by transactions.

    +

    Ur/Web features a module system very similar to those found in SML and OCaml. Like in OCaml, interface files are treated as module system signatures, and they are ascribed to structures built from implementation files. hello.urs tells us that we only export a function named main, taking no arguments and running a transaction that results in an HTML page. transaction is a monad in the spirit of the Haskell IO monad, with the intent that every operation performable in transaction can be undone. By design, Ur/Web does not provide a less constrained way of running side-effecting actions. This particular example application will employ no side effects, but the compiler requires that all pages be generated by transactions.

    Looking at hello.ur, we see an SML-looking function definition that returns a fragment of XML, written with special syntax. This fragment is returned to browsers that request the URI /Demo/Hello/main. That is, we take the demo-wide prefix /Demo and add a suffix that indicates we want to call the main function in the Hello module. This path convention generalizes to arbitrary levels of nested module definitions and functor applications (which we will see later).

    -- cgit v1.2.3 From 1e6547284fbe62b1604d12b651a161709b30851f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 20 Nov 2008 14:51:14 -0500 Subject: Update CHANGELOG for 20081120 --- CHANGELOG | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/CHANGELOG b/CHANGELOG index 4ce8e4c2..a9cc96db 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,12 @@ +======== +20081120 +======== + +- Fix bug that sometimes led to omission of initial "" in pages +- Take advantage of nested functions in some demos +- "profile" option that may appear in .urp files, to enable gprof profiling +- "-guided-demo" option that works like "-demo" but uses less screen space for prose + ======== 20081118 ======== -- cgit v1.2.3 From 261ebaa5168b307ad38825c95d60c5bea5d9858f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 23 Nov 2008 11:47:28 -0500 Subject: Ignore SIGPIPE --- src/c/driver.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/c/driver.c b/src/c/driver.c index ce0d194e..a9a5ce3f 100644 --- a/src/c/driver.c +++ b/src/c/driver.c @@ -313,7 +313,8 @@ int main(int argc, char *argv[]) { int uw_port = 8080, nthreads = 1, i, *names, opt; signal(SIGINT, sigint); - + signal(SIGPIPE, SIG_IGN); + while ((opt = getopt(argc, argv, "hp:t:")) != -1) { switch (opt) { case '?': -- cgit v1.2.3 From 940865b04fa534983982b261386a3b1926bd5531 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 25 Nov 2008 10:05:44 -0500 Subject: Fusing writes with recursive function calls --- CHANGELOG | 5 +++ src/compiler.sig | 4 ++ src/compiler.sml | 13 +++++- src/fuse.sig | 32 ++++++++++++++ src/fuse.sml | 130 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/mono_opt.sig | 1 + src/mono_opt.sml | 2 + src/mono_util.sig | 7 +++ src/mono_util.sml | 21 ++++++++- src/sources | 3 ++ 10 files changed, 216 insertions(+), 2 deletions(-) create mode 100644 src/fuse.sig create mode 100644 src/fuse.sml diff --git a/CHANGELOG b/CHANGELOG index a9cc96db..cbd67118 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,8 @@ +======== +======== + +- Optimization: Fusing page writes with calls to recursive functions + ======== 20081120 ======== diff --git a/src/compiler.sig b/src/compiler.sig index af086675..8c52ea32 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -76,6 +76,7 @@ signature COMPILER = sig val untangle : (Mono.file, Mono.file) phase val mono_reduce : (Mono.file, Mono.file) phase val mono_shake : (Mono.file, Mono.file) phase + val fuse : (Mono.file, Mono.file) phase val pathcheck : (Mono.file, Mono.file) phase val cjrize : (Mono.file, Cjr.file) phase val prepare : (Cjr.file, Cjr.file) phase @@ -104,6 +105,9 @@ signature COMPILER = sig val toMono_reduce : (string, Mono.file) transform val toMono_shake : (string, Mono.file) transform val toMono_opt2 : (string, Mono.file) transform + val toFuse : (string, Mono.file) transform + val toUntangle2 : (string, Mono.file) transform + val toMono_shake2 : (string, Mono.file) transform val toPathcheck : (string, Mono.file) transform val toCjrize : (string, Cjr.file) transform val toPrepare : (string, Cjr.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 6a6c4391..aac4a924 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -523,12 +523,23 @@ val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake +val fuse = { + func = Fuse.fuse, + print = MonoPrint.p_file MonoEnv.empty +} + +val toFuse = transform fuse "fuse" o toMono_opt2 + +val toUntangle2 = transform untangle "untangle2" o toFuse + +val toMono_shake2 = transform mono_shake "mono_shake2" o toUntangle2 + val pathcheck = { func = (fn file => (PathCheck.check file; file)), print = MonoPrint.p_file MonoEnv.empty } -val toPathcheck = transform pathcheck "pathcheck" o toMono_opt2 +val toPathcheck = transform pathcheck "pathcheck" o toMono_shake2 val cjrize = { func = Cjrize.cjrize, diff --git a/src/fuse.sig b/src/fuse.sig new file mode 100644 index 00000000..3ad45ac9 --- /dev/null +++ b/src/fuse.sig @@ -0,0 +1,32 @@ +(* 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. + *) + +signature FUSE = sig + + val fuse : Mono.file -> Mono.file + +end diff --git a/src/fuse.sml b/src/fuse.sml new file mode 100644 index 00000000..b6bd6b47 --- /dev/null +++ b/src/fuse.sml @@ -0,0 +1,130 @@ +(* 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. + *) + +structure Fuse :> FUSE = struct + +open Mono +structure U = MonoUtil + +structure IM = IntBinaryMap + +fun returnsString (t, loc) = + let + fun rs (t, loc) = + case t of + TFfi ("Basis", "string") => SOME ([], (TRecord [], loc)) + | TFun (dom, ran) => + (case rs ran of + NONE => NONE + | SOME (args, ran') => SOME (dom :: args, (TFun (dom, ran'), loc))) + | _ => NONE + in + case t of + TFun (dom, ran) => + (case rs ran of + NONE => NONE + | SOME (args, ran') => SOME (dom :: args, (TFun (dom, ran'), loc))) + | _ => NONE + end + +fun fuse file = + let + fun doDecl (d as (_, loc), (funcs, maxName)) = + let + val (d, funcs, maxName) = + case #1 d of + DValRec vis => + let + val (vis', funcs, maxName) = + foldl (fn ((x, n, t, e, s), (vis', funcs, maxName)) => + case returnsString t of + NONE => (vis', funcs, maxName) + | SOME (args, t') => + let + fun getBody (e, args) = + case (#1 e, args) of + (_, []) => (e, []) + | (EAbs (x, t, _, e), _ :: args) => + let + val (body, args') = getBody (e, args) + in + (body, (x, t) :: args') + end + | _ => raise Fail "Fuse: getBody" + + val (body, args) = getBody (e, args) + val body = MonoOpt.optExp (EWrite body, loc) + val (body, _) = foldl (fn ((x, dom), (body, ran)) => + ((EAbs (x, dom, ran, body), loc), + (TFun (dom, ran), loc))) + (body, (TRecord [], loc)) args + in + ((x, maxName, t', body, s) :: vis', + IM.insert (funcs, n, maxName), + maxName + 1) + end) + ([], funcs, maxName) vis + in + ((DValRec (vis @ vis'), loc), funcs, maxName) + end + | _ => (d, funcs, maxName) + + fun exp e = + case e of + EWrite e' => + let + fun unravel (e, loc) = + case e of + ENamed n => + (case IM.find (funcs, n) of + NONE => NONE + | SOME n' => SOME (ENamed n', loc)) + | EApp (e1, e2) => + (case unravel e1 of + NONE => NONE + | SOME e1 => SOME (EApp (e1, e2), loc)) + | _ => NONE + in + case unravel e' of + NONE => e + | SOME (e', _) => e' + end + | _ => e + in + (U.Decl.map {typ = fn x => x, + exp = exp, + decl = fn x => x} + d, + (funcs, maxName)) + end + + val (file, _) = ListUtil.foldlMap doDecl (IM.empty, U.File.maxName file + 1) file + in + file + end + +end diff --git a/src/mono_opt.sig b/src/mono_opt.sig index d147e7bc..d0268087 100644 --- a/src/mono_opt.sig +++ b/src/mono_opt.sig @@ -28,5 +28,6 @@ signature MONO_OPT = sig val optimize : Mono.file -> Mono.file + val optExp : Mono.exp -> Mono.exp end diff --git a/src/mono_opt.sml b/src/mono_opt.sml index b56372c7..6c0e6e21 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -366,4 +366,6 @@ and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e) val optimize = U.File.map {typ = typ, exp = exp, decl = decl} +val optExp = U.Exp.map {typ = typ, exp = exp} + end diff --git a/src/mono_util.sig b/src/mono_util.sig index 4e9d5d91..32a83855 100644 --- a/src/mono_util.sig +++ b/src/mono_util.sig @@ -90,6 +90,11 @@ structure Decl : sig exp : Mono.exp' * 'state -> 'state, decl : Mono.decl' * 'state -> 'state} -> 'state -> Mono.decl -> 'state + + val map : {typ : Mono.typ' -> Mono.typ', + exp : Mono.exp' -> Mono.exp', + decl : Mono.decl' -> Mono.decl'} + -> Mono.decl -> Mono.decl end structure File : sig @@ -121,6 +126,8 @@ structure File : sig exp : Mono.exp' * 'state -> 'state, decl : Mono.decl' * 'state -> 'state} -> 'state -> Mono.file -> 'state + + val maxName : Mono.file -> int end end diff --git a/src/mono_util.sml b/src/mono_util.sml index 14ab1674..2b2476e7 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -422,6 +422,13 @@ fun fold {typ, exp, decl} s d = S.Continue (_, s) => s | S.Return _ => raise Fail "MonoUtil.Decl.fold: Impossible" +fun map {typ, exp, decl} e = + case mapfold {typ = fn c => fn () => S.Continue (typ c, ()), + exp = fn e => fn () => S.Continue (exp e, ()), + decl = fn d => fn () => S.Continue (decl d, ())} e () of + S.Return () => raise Fail "MonoUtil.Decl.map: Impossible" + | S.Continue (e, ()) => e + end structure File = struct @@ -490,7 +497,7 @@ fun map {typ, exp, decl} e = case mapfold {typ = fn c => fn () => S.Continue (typ c, ()), exp = fn e => fn () => S.Continue (exp e, ()), decl = fn d => fn () => S.Continue (decl d, ())} e () of - S.Return () => raise Fail "Mono_util.File.map" + S.Return () => raise Fail "MonoUtil.File.map: Impossible" | S.Continue (e, ()) => e fun fold {typ, exp, decl} s d = @@ -500,6 +507,18 @@ fun fold {typ, exp, decl} s d = S.Continue (_, s) => s | S.Return _ => raise Fail "MonoUtil.File.fold: Impossible" +val maxName = foldl (fn ((d, _) : decl, count) => + case d of + DDatatype (_, n, ns) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + (Int.max (n, count)) ns + | DVal (_, n, _, _, _) => Int.max (n, count) + | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis + | DExport _ => count + | DTable _ => count + | DSequence _ => count + | DDatabase _ => count) 0 + end end diff --git a/src/sources b/src/sources index bddcac67..13f505d0 100644 --- a/src/sources +++ b/src/sources @@ -140,6 +140,9 @@ mono_shake.sml pathcheck.sig pathcheck.sml +fuse.sig +fuse.sml + cjr.sml cjr_env.sig -- cgit v1.2.3 From a42fe6be6ba6dcb629a6e522624de6506dd7852e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 25 Nov 2008 15:57:16 -0500 Subject: Profiling in Makefile --- .hgignore | 1 + Makefile.in | 4 ++++ 2 files changed, 5 insertions(+) diff --git a/.hgignore b/.hgignore index 8c3417d4..b388b26a 100644 --- a/.hgignore +++ b/.hgignore @@ -26,3 +26,4 @@ demo/out/*.html demo/demo.* *.sql +*mlmon.out diff --git a/Makefile.in b/Makefile.in index ff1f4b6a..a12cb59b 100644 --- a/Makefile.in +++ b/Makefile.in @@ -53,6 +53,10 @@ ifdef DEBUG MLTON += -const 'Exn.keepHistory true' endif +ifdef PROFILE + MLTON += -profile $(PROFILE) +endif + bin/urweb: src/urweb.mlb src/*.sig src/*.sml \ src/urweb.mlton.lex.sml \ src/urweb.mlton.grm.sig src/urweb.mlton.grm.sml -- cgit v1.2.3 From 125bd1380f059c9ee3541df4cbf0e12e2b6dcc70 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 26 Nov 2008 12:13:00 -0500 Subject: Start of new Reduce --- src/reduce.sml | 274 ++++++++++++++++++++++++++++----------------------------- 1 file changed, 133 insertions(+), 141 deletions(-) diff --git a/src/reduce.sml b/src/reduce.sml index e480dea2..7531e0ca 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -31,150 +31,142 @@ structure Reduce :> REDUCE = struct open Core -structure E = CoreEnv -structure U = CoreUtil - -val liftConInCon = E.liftConInCon -val subConInCon = E.subConInCon -val liftConInExp = E.liftConInExp -val liftExpInExp = E.liftExpInExp -val subExpInExp = E.subExpInExp -val liftConInExp = E.liftConInExp -val subConInExp = E.subConInExp - -fun bindC (env, b) = - case b of - U.Con.Rel (x, k) => E.pushCRel env x k - | U.Con.Named (x, n, k, co) => E.pushCNamed env x n k co - -fun bind (env, b) = - case b of - U.Decl.RelC (x, k) => E.pushCRel env x k - | U.Decl.NamedC (x, n, k, co) => E.pushCNamed env x n k co - | U.Decl.RelE (x, t) => E.pushERel env x t - | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s - -fun kind k = k - -fun con env c = - case c of - CApp ((CApp ((CApp ((CFold ks, _), f), _), i), loc), (CRecord (k, xcs), _)) => - (case xcs of - [] => #1 i - | (n, v) :: rest => - #1 (reduceCon env (CApp ((CApp ((CApp (f, n), loc), v), loc), - (CApp ((CApp ((CApp ((CFold ks, loc), f), loc), i), loc), - (CRecord (k, rest), loc)), loc)), loc))) - | CApp ((CAbs (_, _, c1), loc), c2) => - #1 (reduceCon env (subConInCon (0, c2) c1)) - | CNamed n => - (case E.lookupCNamed env n of - (_, _, SOME c') => #1 c' - | _ => c) - | CConcat ((CRecord (k, xcs1), loc), (CRecord (_, xcs2), _)) => CRecord (k, xcs1 @ xcs2) - - | CProj ((CTuple cs, _), n) => #1 (List.nth (cs, n - 1)) - - | _ => c - -and reduceCon env = U.Con.mapB {kind = kind, con = con, bind = bindC} env - -fun exp env e = +structure IM = IntBinaryMap + +datatype env_item = + UnknownC + | KnownC of con + + | UnknownE + | KnownE of exp + + | Lift of int * int + +type env = env_item list + +fun conAndExp (namedC, namedE) = let - (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp env (e, ErrorMsg.dummySpan))]*) - - val r = case e of - ENamed n => - (case E.lookupENamed env n of - (_, _, SOME e', _) => #1 e' - | _ => e) - - | ECApp ((EApp ((EApp ((ECApp ((EFold ks, _), ran), _), f), _), i), _), (CRecord (k, xcs), loc)) => - (case xcs of - [] => #1 i - | (n, v) :: rest => - #1 (reduceExp env (EApp ((ECApp ((ECApp ((ECApp (f, n), loc), v), loc), (CRecord (k, rest), loc)), loc), - (ECApp ((EApp ((EApp ((ECApp ((EFold ks, loc), ran), loc), f), loc), i), loc), - (CRecord (k, rest), loc)), loc)), loc))) - - | EApp ((EAbs (_, _, _, e1), loc), e2) => - #1 (reduceExp env (subExpInExp (0, e2) e1)) - | ECApp ((ECAbs (_, _, e1), loc), c) => - #1 (reduceExp env (subConInExp (0, c) e1)) - - | EField ((ERecord xes, _), (CName x, _), _) => - (case List.find (fn ((CName x', _), _, _) => x' = x - | _ => false) xes of - SOME (_, e, _) => #1 e - | NONE => e) - | EConcat (r1 as (_, loc), (CRecord (k, xts1), _), r2, (CRecord (_, xts2), _)) => - let - 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 (r, rest, (x, t) :: passed) - in - #1 (reduceExp env (ERecord (fields (r1, xts1, []) @ fields (r2, xts2, [])), loc)) - end - | ECut (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 - | 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 + fun con env (all as (c, loc)) = + case c of + TFun (c1, c2) => (TFun (con env c1, con env c2), loc) + | TCFun (x, k, c2) => (TCFun (x, k, con (UnknownC :: env) c2), loc) + | TRecord c => (TRecord (con env c), loc) + + | CRel n => + let + fun find (n', env, lift) = + if n' = 0 then + case env of + UnknownC :: _ => (CRel (n + lift), loc) + | KnownC c :: _ => con (Lift (lift, 0) :: env) c + | _ => raise Fail "Reduce.con: CRel [1]" + else + case env of + UnknownC :: rest => find (n' - 1, rest, lift + 1) + | KnownC _ :: rest => find (n' - 1, rest, lift) + | UnknownE :: rest => find (n' - 1, rest, lift) + | KnownE _ :: rest => find (n' - 1, rest, lift) + | Lift (lift', _) :: rest => find (n' - 1, rest, lift + lift') + | [] => raise Fail "Reduce.con: CRel [2]" + in + find (n, env, 0) + end + | CNamed n => + (case IM.find (namedC, n) of + NONE => all + | SOME c => c) + | CFfi _ => all + | CApp (c1, c2) => + let + val c1 = con env c1 + val c2 = con env c2 + in + case #1 c1 of + CAbs (_, _, b) => + con (KnownC c2 :: env) b + + | CApp ((CApp (fold as (CFold _, _), f), _), i) => + (case #1 c2 of + CRecord (_, []) => i + | CRecord (k, (x, c) :: rest) => + con env (CApp ((CApp ((CApp (f, x), loc), c), loc), + (CApp ((CApp ((CApp (fold, f), loc), i), loc), + (CRecord (k, rest), loc)), loc)), loc) + | _ => (CApp (c1, c2), loc)) + + | _ => (CApp (c1, c2), loc) + end + | CAbs (x, k, b) => (CAbs (x, k, con (UnknownC :: env) b), loc) + + | CName _ => all + + | CRecord (k, xcs) => (CRecord (k, map (fn (x, c) => (con env x, con env c)) xcs), loc) + | CConcat (c1, c2) => + let + val c1 = con env c1 + val c2 = con env c2 + in + case (#1 c1, #1 c2) of + (CRecord (k, xcs1), CRecord (_, xcs2)) => + (CRecord (k, xcs1 @ xcs2), loc) + | _ => (CConcat (c1, c2), loc) + end + | CFold _ => all + + | CUnit => all + + | CTuple cs => (CTuple (map (con env) cs), loc) + | CProj (c, n) => + let + val c = con env c + in + case #1 c of + CTuple cs => List.nth (cs, n - 1) + | _ => (CProj (c, n), loc) + end + + fun exp env e = e in - (*Print.prefaces "exp'" [("e", CorePrint.p_exp env (e, ErrorMsg.dummySpan)), - ("r", CorePrint.p_exp env (r, ErrorMsg.dummySpan))];*) - - r + {con = con, exp = exp} end -and reduceExp env = U.Exp.mapB {kind = kind, con = con, exp = exp, bind = bind} env - -fun decl env d = - case d of - DValRec [vi as (_, n, _, e, _)] => - let - fun kind _ = false - fun con _ = false - fun exp e = - case e of - ENamed n' => n' = n - | _ => false - in - if U.Exp.exists {kind = kind, con = con, exp = exp} e then - d - else - DVal vi - end - | _ => d - -val reduce = U.File.mapB {kind = kind, con = con, exp = exp, decl = decl, bind = bind} E.empty +fun con namedC c = #con (conAndExp (namedC, IM.empty)) [] c +fun exp (namedC, namedE) e = #exp (conAndExp (namedC, namedE)) [] e + +fun reduce file = + let + fun doDecl (d as (_, loc), st as (namedC, namedE)) = + case #1 d of + DCon (x, n, k, c) => + let + val c = con namedC c + in + ((DCon (x, n, k, c), loc), + (IM.insert (namedC, n, c), namedE)) + end + | DDatatype (x, n, ps, cs) => + ((DDatatype (x, n, ps, map (fn (x, n, co) => (x, n, Option.map (con namedC) co)) cs), loc), + st) + | DVal (x, n, t, e, s) => + let + val t = con namedC t + val e = exp (namedC, namedE) e + in + ((DVal (x, n, t, e, s), loc), + (namedC, IM.insert (namedE, n, e))) + end + | DValRec vis => + ((DValRec (map (fn (x, n, t, e, s) => (x, n, con namedC t, exp (namedC, namedE) e, s)) vis), loc), + st) + | DExport _ => (d, st) + | DTable (s, n, c, s') => ((DTable (s, n, con namedC c, s'), loc), st) + | DSequence _ => (d, st) + | DDatabase _ => (d, st) + | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC c, s'), loc), st) + + val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty) file + in + file + end end -- cgit v1.2.3 From c767386f0b9d6af9ac3e306f73ea0608cb521c7b Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 26 Nov 2008 12:59:32 -0500 Subject: Most exp rules for new Reduce --- src/reduce.sml | 231 ++++++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 219 insertions(+), 12 deletions(-) diff --git a/src/reduce.sml b/src/reduce.sml index 7531e0ca..3d117fb5 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -59,6 +59,7 @@ fun conAndExp (namedC, namedE) = case env of UnknownC :: _ => (CRel (n + lift), loc) | KnownC c :: _ => con (Lift (lift, 0) :: env) c + | Lift (lift', _) :: rest => find (0, rest, lift + lift') | _ => raise Fail "Reduce.con: CRel [1]" else case env of @@ -66,7 +67,7 @@ fun conAndExp (namedC, namedE) = | KnownC _ :: rest => find (n' - 1, rest, lift) | UnknownE :: rest => find (n' - 1, rest, lift) | KnownE _ :: rest => find (n' - 1, rest, lift) - | Lift (lift', _) :: rest => find (n' - 1, rest, lift + lift') + | Lift (lift', _) :: rest => find (n', rest, lift + lift') | [] => raise Fail "Reduce.con: CRel [2]" in find (n, env, 0) @@ -125,13 +126,215 @@ fun conAndExp (namedC, namedE) = | _ => (CProj (c, n), loc) end - fun exp env e = e + fun patCon pc = + case pc of + PConVar _ => pc + | PConFfi {mod = m, datatyp, params, con = c, arg, kind} => + PConFfi {mod = m, datatyp = datatyp, params = params, con = c, + arg = Option.map (con (map (fn _ => UnknownC) params)) arg, + kind = kind} + + + val k = (KType, ErrorMsg.dummySpan) + fun doPart e (this as (x, t), rest) = + ((x, (EField (e, x, {field = t, rest = (CRecord (k, rest), #2 t)}), #2 t), t), + this :: rest) + + fun exp env (all as (e, loc)) = + case e of + EPrim _ => all + | ERel n => + let + fun find (n', env, liftC, liftE) = + if n' = 0 then + case env of + UnknownE :: _ => (ERel (n + liftE), loc) + | KnownE e :: _ => exp (Lift (liftC, liftE) :: env) e + | Lift (liftC', liftE') :: rest => find (0, rest, liftC + liftC', liftE + liftE') + | _ => raise Fail "Reduce.exp: ERel [1]" + else + case env of + UnknownC :: rest => find (n' - 1, rest, liftC + 1, liftE) + | KnownC _ :: rest => find (n' - 1, rest, liftC, liftE) + | UnknownE :: rest => find (n' - 1, rest, liftC, liftE + 1) + | KnownE _ :: rest => find (n' - 1, rest, liftC, liftE) + | Lift (liftC', liftE') :: rest => find (n', rest, liftC + liftC', liftE + liftE') + | [] => raise Fail "Reduce.exp: ERel [2]" + in + find (n, env, 0, 0) + end + | ENamed n => + (case IM.find (namedE, n) of + NONE => all + | SOME e => e) + | ECon (dk, pc, cs, eo) => (ECon (dk, patCon pc, + map (con env) cs, Option.map (exp env) eo), loc) + | EFfi _ => all + | EFfiApp (m, f, es) => (EFfiApp (m, f, map (exp env) es), loc) + + | EApp (e1, e2) => + let + val e1 = exp env e1 + val e2 = exp env e2 + in + case #1 e1 of + EAbs (_, _, _, b) => exp (KnownE e2 :: env) b + | _ => (EApp (e1, e2), loc) + end + + | EAbs (x, dom, ran, e) => (EAbs (x, con env dom, con env ran, exp (UnknownE :: env) e), loc) + + | ECApp (e, c) => + let + val e = exp env e + val c = con env c + in + case #1 e of + ECAbs (_, _, b) => exp (KnownC c :: env) b + | _ => (ECApp (e, c), loc) + end + + | ECAbs (x, k, e) => (ECAbs (x, k, exp (UnknownC :: env) e), loc) + + | ERecord xcs => (ERecord (map (fn (x, e, t) => (con env x, exp env e, con env t)) xcs), loc) + | EField (e, c, {field, rest}) => + let + val e = exp env e + val c = con env c + + fun default () = (EField (e, c, {field = con env field, rest = con env rest}), loc) + in + case (#1 e, #1 c) of + (ERecord xcs, CName x) => + (case List.find (fn ((CName x', _), _, _) => x' = x | _ => false) xcs of + NONE => default () + | SOME (_, e, _) => e) + | _ => default () + end + + | EConcat (e1, c1, e2, c2) => + let + val e1 = exp env e1 + val e2 = exp env e2 + in + case (#1 e1, #1 e2) of + (ERecord xes1, ERecord xes2) => (ERecord (xes1 @ xes2), loc) + | _ => + let + val c1 = con env c1 + val c2 = con env c2 + in + case (#1 c1, #1 c2) of + (CRecord (k, xcs1), CRecord (_, xcs2)) => + let + val (xes1, rest) = ListUtil.foldlMap (doPart e1) [] xcs1 + val (xes2, _) = ListUtil.foldlMap (doPart e2) rest xcs2 + in + exp env (ERecord (xes1 @ xes2), loc) + end + | _ => (EConcat (e1, c1, e2, c2), loc) + end + end + + | ECut (e, c, {field, rest}) => + let + val e = exp env e + val c = con env c + + fun default () = + let + val rest = con env rest + in + case #1 rest of + CRecord (k, xcs) => + let + val (xes, _) = ListUtil.foldlMap (doPart e) [] xcs + in + exp env (ERecord xes, loc) + end + | _ => (ECut (e, c, {field = con env field, rest = rest}), loc) + end + in + case (#1 e, #1 c) of + (ERecord xes, CName x) => + if List.all (fn ((CName _, _), _, _) => true | _ => false) xes then + (ERecord (List.filter (fn ((CName x', _), _, _) => x' <> x + | _ => raise Fail "Reduce: ECut") xes), loc) + else + default () + | _ => default () + end + + | ECutMulti (e, c, {rest}) => + let + val e = exp env e + val c = con env c + + fun default () = + let + val rest = con env rest + in + case #1 rest of + CRecord (k, xcs) => + let + val (xes, _) = ListUtil.foldlMap (doPart e) [] xcs + in + exp env (ERecord xes, loc) + end + | _ => (ECutMulti (e, c, {rest = rest}), loc) + end + in + case (#1 e, #1 c) of + (ERecord xes, CRecord (_, xcs)) => + if List.all (fn ((CName _, _), _, _) => true | _ => false) xes + andalso List.all (fn ((CName _, _), _) => true | _ => false) xcs then + (ERecord (List.filter (fn ((CName x', _), _, _) => + List.all (fn ((CName x, _), _) => x' <> x + | _ => raise Fail "Reduce: ECutMulti [1]") xcs + | _ => raise Fail "Reduce: ECutMulti [2]") xes), loc) + else + default () + | _ => default () + end + + | EFold _ => all + + | ECase (e, pes, {disc, result}) => + let + fun patBinds (p, _) = + case p of + PWild => 0 + | PVar _ => 1 + | PPrim _ => 0 + | PCon (_, _, _, NONE) => 0 + | PCon (_, _, _, SOME p) => patBinds p + | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts + + fun pat (all as (p, loc)) = + case p of + PWild => all + | PVar (x, t) => (PVar (x, con env t), loc) + | PPrim _ => all + | PCon (dk, pc, cs, po) => + (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc) + | PRecord xpts => (PRecord (map (fn (x, p, t) => (x, pat p, con env t)) xpts), loc) + in + (ECase (exp env e, + map (fn (p, e) => (pat p, + exp (List.tabulate (patBinds p, fn _ => UnknownE) @ env) e)) + pes, {disc = con env disc, result = con env result}), loc) + end + + | EWrite e => (EWrite (exp env e), loc) + | EClosure (n, es) => (EClosure (n, map (exp env) es), loc) + + | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc) in {con = con, exp = exp} end -fun con namedC c = #con (conAndExp (namedC, IM.empty)) [] c -fun exp (namedC, namedE) e = #exp (conAndExp (namedC, namedE)) [] e +fun con namedC env c = #con (conAndExp (namedC, IM.empty)) env c +fun exp (namedC, namedE) env e = #exp (conAndExp (namedC, namedE)) env e fun reduce file = let @@ -139,30 +342,34 @@ fun reduce file = case #1 d of DCon (x, n, k, c) => let - val c = con namedC c + val c = con namedC [] c in ((DCon (x, n, k, c), loc), (IM.insert (namedC, n, c), namedE)) end | DDatatype (x, n, ps, cs) => - ((DDatatype (x, n, ps, map (fn (x, n, co) => (x, n, Option.map (con namedC) co)) cs), loc), - st) + let + val env = map (fn _ => UnknownC) ps + in + ((DDatatype (x, n, ps, map (fn (x, n, co) => (x, n, Option.map (con namedC env) co)) cs), loc), + st) + end | DVal (x, n, t, e, s) => let - val t = con namedC t - val e = exp (namedC, namedE) e + val t = con namedC [] t + val e = exp (namedC, namedE) [] e in ((DVal (x, n, t, e, s), loc), (namedC, IM.insert (namedE, n, e))) end | DValRec vis => - ((DValRec (map (fn (x, n, t, e, s) => (x, n, con namedC t, exp (namedC, namedE) e, s)) vis), loc), + ((DValRec (map (fn (x, n, t, e, s) => (x, n, con namedC [] t, exp (namedC, namedE) [] e, s)) vis), loc), st) | DExport _ => (d, st) - | DTable (s, n, c, s') => ((DTable (s, n, con namedC c, s'), loc), st) + | DTable (s, n, c, s') => ((DTable (s, n, con namedC [] c, s'), loc), st) | DSequence _ => (d, st) | DDatabase _ => (d, st) - | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC c, s'), loc), st) + | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st) val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty) file in -- cgit v1.2.3 From 879bb7d5c760d277348a4ab9f799143013680f08 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 26 Nov 2008 14:51:52 -0500 Subject: Fix environments for repeat visits for exp reduction --- src/reduce.sml | 110 +++++++++++++++++++++++++++++++++++---------------------- 1 file changed, 67 insertions(+), 43 deletions(-) diff --git a/src/reduce.sml b/src/reduce.sml index 3d117fb5..5b4d7a49 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -44,9 +44,24 @@ datatype env_item = type env = env_item list +fun ei2s ei = + case ei of + UnknownC => "UC" + | KnownC _ => "KC" + | UnknownE => "UE" + | KnownE _ => "KE" + | Lift (n1, n2) => "(" ^ Int.toString n1 ^ ", " ^ Int.toString n2 ^ ")" + +fun e2s env = String.concatWith " " (map ei2s env) + +val deKnown = List.filter (fn KnownC _ => false + | KnownE _ => false + | _ => true) + fun conAndExp (namedC, namedE) = let fun con env (all as (c, loc)) = + ((*Print.prefaces "con" [("c", CorePrint.p_con CoreEnv.empty all)];*) case c of TFun (c1, c2) => (TFun (con env c1, con env c2), loc) | TCFun (x, k, c2) => (TCFun (x, k, con (UnknownC :: env) c2), loc) @@ -54,23 +69,25 @@ fun conAndExp (namedC, namedE) = | CRel n => let - fun find (n', env, lift) = - if n' = 0 then - case env of - UnknownC :: _ => (CRel (n + lift), loc) - | KnownC c :: _ => con (Lift (lift, 0) :: env) c - | Lift (lift', _) :: rest => find (0, rest, lift + lift') - | _ => raise Fail "Reduce.con: CRel [1]" - else - case env of - UnknownC :: rest => find (n' - 1, rest, lift + 1) - | KnownC _ :: rest => find (n' - 1, rest, lift) - | UnknownE :: rest => find (n' - 1, rest, lift) - | KnownE _ :: rest => find (n' - 1, rest, lift) - | Lift (lift', _) :: rest => find (n', rest, lift + lift') - | [] => raise Fail "Reduce.con: CRel [2]" + fun find (n', env, nudge, lift) = + case env of + [] => raise Fail "Reduce.con: CRel" + | UnknownE :: rest => find (n', rest, nudge, lift) + | KnownE _ :: rest => find (n', rest, nudge, lift) + | Lift (lift', _) :: rest => find (n', rest, nudge + lift', lift + lift') + | UnknownC :: rest => + if n' = 0 then + (CRel (n + nudge), loc) + else + find (n' - 1, rest, nudge, lift + 1) + | KnownC c :: rest => + if n' = 0 then + con (Lift (lift, 0) :: rest) c + else + find (n' - 1, rest, nudge - 1, lift) in - find (n, env, 0) + (*print (Int.toString n ^ ": " ^ e2s env ^ "\n");*) + find (n, env, 0, 0) end | CNamed n => (case IM.find (namedC, n) of @@ -84,15 +101,16 @@ fun conAndExp (namedC, namedE) = in case #1 c1 of CAbs (_, _, b) => - con (KnownC c2 :: env) b + con (KnownC c2 :: deKnown env) b | CApp ((CApp (fold as (CFold _, _), f), _), i) => (case #1 c2 of CRecord (_, []) => i | CRecord (k, (x, c) :: rest) => - con env (CApp ((CApp ((CApp (f, x), loc), c), loc), - (CApp ((CApp ((CApp (fold, f), loc), i), loc), - (CRecord (k, rest), loc)), loc)), loc) + con (deKnown env) + (CApp ((CApp ((CApp (f, x), loc), c), loc), + (CApp ((CApp ((CApp (fold, f), loc), i), loc), + (CRecord (k, rest), loc)), loc)), loc) | _ => (CApp (c1, c2), loc)) | _ => (CApp (c1, c2), loc) @@ -124,7 +142,7 @@ fun conAndExp (namedC, namedE) = case #1 c of CTuple cs => List.nth (cs, n - 1) | _ => (CProj (c, n), loc) - end + end) fun patCon pc = case pc of @@ -141,27 +159,33 @@ fun conAndExp (namedC, namedE) = this :: rest) fun exp env (all as (e, loc)) = + ((*Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all), + ("env", Print.PD.string (e2s env))];*) case e of EPrim _ => all | ERel n => let - fun find (n', env, liftC, liftE) = - if n' = 0 then - case env of - UnknownE :: _ => (ERel (n + liftE), loc) - | KnownE e :: _ => exp (Lift (liftC, liftE) :: env) e - | Lift (liftC', liftE') :: rest => find (0, rest, liftC + liftC', liftE + liftE') - | _ => raise Fail "Reduce.exp: ERel [1]" - else - case env of - UnknownC :: rest => find (n' - 1, rest, liftC + 1, liftE) - | KnownC _ :: rest => find (n' - 1, rest, liftC, liftE) - | UnknownE :: rest => find (n' - 1, rest, liftC, liftE + 1) - | KnownE _ :: rest => find (n' - 1, rest, liftC, liftE) - | Lift (liftC', liftE') :: rest => find (n', rest, liftC + liftC', liftE + liftE') - | [] => raise Fail "Reduce.exp: ERel [2]" + fun find (n', env, nudge, liftC, liftE) = + case env of + [] => raise Fail "Reduce.exp: ERel" + | UnknownC :: rest => find (n', rest, nudge, liftC + 1, liftE) + | KnownC _ :: rest => find (n', rest, nudge, liftC, liftE) + | Lift (liftC', liftE') :: rest => find (n', rest, nudge + liftE', + liftC + liftC', liftE + liftE') + | UnknownE :: rest => + if n' = 0 then + (ERel (n + nudge), loc) + else + find (n' - 1, rest, nudge, liftC, liftE + 1) + | KnownE e :: rest => + if n' = 0 then + ((*print "SUBSTITUTING\n";*) + exp (Lift (liftC, liftE) :: rest) e) + else + find (n' - 1, rest, nudge - 1, liftC, liftE) in - find (n, env, 0, 0) + (*print (Int.toString n ^ ": " ^ e2s env ^ "\n");*) + find (n, env, 0, 0, 0) end | ENamed n => (case IM.find (namedE, n) of @@ -178,7 +202,7 @@ fun conAndExp (namedC, namedE) = val e2 = exp env e2 in case #1 e1 of - EAbs (_, _, _, b) => exp (KnownE e2 :: env) b + EAbs (_, _, _, b) => exp (KnownE e2 :: deKnown env) b | _ => (EApp (e1, e2), loc) end @@ -190,7 +214,7 @@ fun conAndExp (namedC, namedE) = val c = con env c in case #1 e of - ECAbs (_, _, b) => exp (KnownC c :: env) b + ECAbs (_, _, b) => exp (KnownC c :: deKnown env) b | _ => (ECApp (e, c), loc) end @@ -230,7 +254,7 @@ fun conAndExp (namedC, namedE) = val (xes1, rest) = ListUtil.foldlMap (doPart e1) [] xcs1 val (xes2, _) = ListUtil.foldlMap (doPart e2) rest xcs2 in - exp env (ERecord (xes1 @ xes2), loc) + exp (deKnown env) (ERecord (xes1 @ xes2), loc) end | _ => (EConcat (e1, c1, e2, c2), loc) end @@ -250,7 +274,7 @@ fun conAndExp (namedC, namedE) = let val (xes, _) = ListUtil.foldlMap (doPart e) [] xcs in - exp env (ERecord xes, loc) + exp (deKnown env) (ERecord xes, loc) end | _ => (ECut (e, c, {field = con env field, rest = rest}), loc) end @@ -279,7 +303,7 @@ fun conAndExp (namedC, namedE) = let val (xes, _) = ListUtil.foldlMap (doPart e) [] xcs in - exp env (ERecord xes, loc) + exp (deKnown env) (ERecord xes, loc) end | _ => (ECutMulti (e, c, {rest = rest}), loc) end @@ -328,7 +352,7 @@ fun conAndExp (namedC, namedE) = | EWrite e => (EWrite (exp env e), loc) | EClosure (n, es) => (EClosure (n, map (exp env) es), loc) - | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc) + | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc)) in {con = con, exp = exp} end -- cgit v1.2.3 From 9d6ca0836f8b54c672449d1100da3d0d36e07611 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 26 Nov 2008 15:03:45 -0500 Subject: crud1 compiles with new Reduce --- src/reduce.sml | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/src/reduce.sml b/src/reduce.sml index 5b4d7a49..a08feb26 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -103,13 +103,13 @@ fun conAndExp (namedC, namedE) = CAbs (_, _, b) => con (KnownC c2 :: deKnown env) b - | CApp ((CApp (fold as (CFold _, _), f), _), i) => + | CApp ((CApp ((CFold _, _), f), _), i) => (case #1 c2 of CRecord (_, []) => i | CRecord (k, (x, c) :: rest) => con (deKnown env) (CApp ((CApp ((CApp (f, x), loc), c), loc), - (CApp ((CApp ((CApp (fold, f), loc), i), loc), + (CApp (c1, (CRecord (k, rest), loc)), loc)), loc) | _ => (CApp (c1, c2), loc)) @@ -215,6 +215,20 @@ fun conAndExp (namedC, namedE) = in case #1 e of ECAbs (_, _, b) => exp (KnownC c :: deKnown env) b + + | EApp ((EApp ((ECApp ((EFold _, _), _), _), f), _), i) => + (case #1 c of + CRecord (_, []) => i + | CRecord (k, (nm, v) :: rest) => + let + val rest = (CRecord (k, rest), loc) + in + exp (deKnown env) + (EApp ((ECApp ((ECApp ((ECApp (f, nm), loc), v), loc), rest), loc), + (ECApp (e, rest), loc)), loc) + end + | _ => (ECApp (e, c), loc)) + | _ => (ECApp (e, c), loc) end -- cgit v1.2.3 From 38f090b51c794b04cfdc5ec7110853c64a2513be Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 26 Nov 2008 15:42:00 -0500 Subject: Port Reduce improvements to ReduceLocal --- src/reduce_local.sml | 138 +++++++++++++++++++++++++++++++++++++++++---------- 1 file changed, 113 insertions(+), 25 deletions(-) diff --git a/src/reduce_local.sml b/src/reduce_local.sml index 6a6d80a8..d80d5770 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -31,39 +31,127 @@ structure ReduceLocal :> REDUCE_LOCAL = struct open Core -structure E = CoreEnv -structure U = CoreUtil +structure IM = IntBinaryMap -val subExpInExp = E.subExpInExp +datatype env_item = + Unknown + | Known of exp -fun default x = x + | Lift of int -fun exp (e : exp') = - let - (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp env (e, ErrorMsg.dummySpan))]*) +type env = env_item list - val r = case e of - EApp ((EAbs (x, t, _, e1), loc), e2) => - ((*Print.prefaces "Substitute" [("x", Print.PD.string x), - ("t", CorePrint.p_con CoreEnv.empty t)];*) - #1 (reduceExp (subExpInExp (0, e2) e1))) +val deKnown = List.filter (fn Known _ => false + | _ => true) - | EField ((ERecord xes, _), (CName x, _), _) => - (case List.find (fn ((CName x', _), _, _) => x' = x - | _ => false) xes of - SOME (_, (e, _), _) => e - | NONE => e) +fun exp env (all as (e, loc)) = + case e of + EPrim _ => all + | ERel n => + let + fun find (n', env, nudge, lift) = + case env of + [] => raise Fail "ReduceLocal.exp: ERel" + | Lift lift' :: rest => find (n', rest, nudge + lift', lift + lift') + | Unknown :: rest => + if n' = 0 then + (ERel (n + nudge), loc) + else + find (n' - 1, rest, nudge, lift + 1) + | Known e :: rest => + if n' = 0 then + ((*print "SUBSTITUTING\n";*) + exp (Lift lift :: rest) e) + else + find (n' - 1, rest, nudge - 1, lift) + in + find (n, env, 0, 0) + end + | ENamed _ => all + | ECon (dk, pc, cs, eo) => (ECon (dk, pc, cs, Option.map (exp env) eo), loc) + | EFfi _ => all + | EFfiApp (m, f, es) => (EFfiApp (m, f, map (exp env) es), loc) - | _ => e - in - (*Print.prefaces "exp'" [("e", CorePrint.p_exp env (e, ErrorMsg.dummySpan)), - ("r", CorePrint.p_exp env (r, ErrorMsg.dummySpan))];*) + | EApp (e1, e2) => + let + val e1 = exp env e1 + val e2 = exp env e2 + in + case #1 e1 of + EAbs (_, _, _, b) => exp (Known e2 :: deKnown env) b + | _ => (EApp (e1, e2), loc) + end - r - end + | EAbs (x, dom, ran, e) => (EAbs (x, dom, ran, exp (Unknown :: env) e), loc) + + | ECApp (e, c) => (ECApp (exp env e, c), loc) + + | ECAbs (x, k, e) => (ECAbs (x, k, exp env e), loc) + + | ERecord xcs => (ERecord (map (fn (x, e, t) => (x, exp env e, t)) xcs), loc) + | EField (e, c, others) => + let + val e = exp env e + + fun default () = (EField (e, c, others), loc) + in + case (#1 e, #1 c) of + (ERecord xcs, CName x) => + (case List.find (fn ((CName x', _), _, _) => x' = x | _ => false) xcs of + NONE => default () + | SOME (_, e, _) => e) + | _ => default () + end -and reduceExp e = U.Exp.map {kind = default, con = default, exp = exp} e + | EConcat (e1, c1, e2, c2) => (EConcat (exp env e1, c1, exp env e2, c2), loc) + | ECut (e, c, others) => (ECut (exp env e, c, others), loc) + | ECutMulti (e, c, others) => (ECutMulti (exp env e, c, others), loc) -val reduce = U.File.map {kind = default, con = default, exp = exp, decl = default} + | EFold _ => all + + | ECase (e, pes, others) => + let + fun patBinds (p, _) = + case p of + PWild => 0 + | PVar _ => 1 + | PPrim _ => 0 + | PCon (_, _, _, NONE) => 0 + | PCon (_, _, _, SOME p) => patBinds p + | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts + in + (ECase (exp env e, + map (fn (p, e) => (p, + exp (List.tabulate (patBinds p, fn _ => Unknown) @ env) e)) + pes, others), loc) + end + + | EWrite e => (EWrite (exp env e), loc) + | EClosure (n, es) => (EClosure (n, map (exp env) es), loc) + + | ELet (x, t, e1, e2) => (ELet (x, t, exp env e1, exp (Unknown :: env) e2), loc) + +fun reduce file = + let + fun doDecl (d as (_, loc)) = + case #1 d of + DCon _ => d + | DDatatype _ => d + | DVal (x, n, t, e, s) => + let + val e = exp [] e + in + (DVal (x, n, t, e, s), loc) + end + | DValRec vis => + (DValRec (map (fn (x, n, t, e, s) => (x, n, t, exp [] e, s)) vis), loc) + | DExport _ => d + | DTable _ => d + | DSequence _ => d + | DDatabase _ => d + | DCookie _ => d + in + map doDecl file + end end -- cgit v1.2.3 From 7bf42fdf1431aa2b15a3bf64d0e6c544cdee68cf Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 27 Nov 2008 10:13:22 -0500 Subject: Remove unnecessary [kindof] calls --- src/elaborate.sml | 59 ++++++++++++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 54 insertions(+), 5 deletions(-) diff --git a/src/elaborate.sml b/src/elaborate.sml index e3d334eb..e3d76ed6 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -540,6 +540,53 @@ exception SummaryFailure + fun isUnitCon env (c, loc) = + case c of + L'.TFun _ => false + | L'.TCFun _ => false + | L'.TRecord _ => false + + | L'.CRel xn => #1 (#2 (E.lookupCRel env xn)) = L'.KUnit + | L'.CNamed xn => #1 (#2 (E.lookupCNamed env xn)) = L'.KUnit + | L'.CModProj (n, ms, x) => + let + val (_, sgn) = E.lookupStrNamed env n + val (str, sgn) = foldl (fn (m, (str, sgn)) => + case E.projectStr env {sgn = sgn, str = str, field = m} of + NONE => raise Fail "kindof: Unknown substructure" + | SOME sgn => ((L'.StrProj (str, m), loc), sgn)) + ((L'.StrVar n, loc), sgn) ms + in + case E.projectCon env {sgn = sgn, str = str, field = x} of + NONE => raise Fail "kindof: Unknown con in structure" + | SOME ((k, _), _) => k = L'.KUnit + end + + | L'.CApp (c, _) => + (case hnormKind (kindof env c) of + (L'.KArrow (_, k), _) => #1 k = L'.KUnit + | (L'.KError, _) => false + | k => raise CUnify' (CKindof (k, c, "arrow"))) + | L'.CAbs _ => false + | L'.CDisjoint (_, _, _, c) => isUnitCon env c + + | L'.CName _ => false + + | L'.CRecord _ => false + | L'.CConcat _ => false + | L'.CFold _ => false + + | L'.CUnit => true + + | L'.CTuple _ => false + | L'.CProj (c, n) => + (case hnormKind (kindof env c) of + (L'.KTuple ks, _) => #1 (List.nth (ks, n - 1)) = L'.KUnit + | k => raise CUnify' (CKindof (k, c, "tuple"))) + + | L'.CError => false + | L'.CUnif (_, k, _, _) => #1 k = L'.KUnit + fun unifyRecordCons (env, denv) (c1, c2) = let fun rkindof c = @@ -824,9 +871,9 @@ gs1 @ gs2 @ gs3 @ gs4 end | _ => - case (kindof env c1, kindof env c2) of - ((L'.KUnit, _), (L'.KUnit, _)) => [] - | _ => + if isUnitCon env c1 andalso isUnitCon env c2 then + [] + else let val (c1, gs1) = hnormCon (env, denv) c1 val (c2, gs2) = hnormCon (env, denv) c2 @@ -1722,7 +1769,8 @@ fun elabExp (env, denv) (eAll as (e, loc)) = ((L'.ELet (eds, e), loc), t, gs1 @ gs2) end in - (*prefaces "/elabExp" [("e", SourcePrint.p_exp eAll)];*) + (*prefaces "elabExp" [("e", SourcePrint.p_exp eAll), + ("t", PD.string (LargeInt.toString (Time.toMilliseconds (Time.- (Time.now (), befor)))))];*) r end @@ -3245,7 +3293,8 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) in (*prefaces "elabDecl" [("e", SourcePrint.p_decl dAll), - ("|tcs|", PD.string (Int.toString (length tcs)))];*) + ("t", PD.string (LargeInt.toString (Time.toMilliseconds + (Time.- (Time.now (), befor)))))];*) r end -- cgit v1.2.3 From 59bc998793e4c715d038555143ac3d83f2b3bc42 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 27 Nov 2008 10:40:29 -0500 Subject: Remove unnecessary lifts in ElabEnv.pushCRel --- src/elab_env.sml | 4 ++-- src/elaborate.sml | 26 ++++++++++++++++++++++---- 2 files changed, 24 insertions(+), 6 deletions(-) diff --git a/src/elab_env.sml b/src/elab_env.sml index 05da56db..3acb855d 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -268,7 +268,7 @@ fun pushCRel (env : env) x k = in {renameC = SM.insert (renameC, x, Rel' (0, k)), relC = (x, k) :: #relC env, - namedC = IM.map (fn (x, k, co) => (x, k, Option.map lift co)) (#namedC env), + namedC = #namedC env, datatypes = #datatypes env, constructors = #constructors env, @@ -283,7 +283,7 @@ fun pushCRel (env : env) x k = renameE = SM.map (fn Rel' (n, c) => Rel' (n, lift c) | Named' (n, c) => Named' (n, lift c)) (#renameE env), relE = map (fn (x, c) => (x, lift c)) (#relE env), - namedE = IM.map (fn (x, c) => (x, lift c)) (#namedE env), + namedE = #namedE env, renameSgn = #renameSgn env, sgn = #sgn env, diff --git a/src/elaborate.sml b/src/elaborate.sml index e3d76ed6..86ae6067 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -875,12 +875,19 @@ [] else let + (*val befor = Time.now () + val old1 = c1 + val old2 = c2*) val (c1, gs1) = hnormCon (env, denv) c1 val (c2, gs2) = hnormCon (env, denv) c2 in let val gs3 = unifyCons'' (env, denv) c1 c2 in + (*prefaces "unifyCons'" [("c1", p_con env old1), + ("c2", p_con env old2), + ("t", PD.string (LargeReal.toString (Time.toReal + (Time.- (Time.now (), befor)))))];*) gs1 @ gs2 @ gs3 end handle ex => guessFold (env, denv) (c1, c2, gs1 @ gs2, ex) @@ -906,7 +913,16 @@ err CExplicitness else (unifyKinds d1 d2; - unifyCons' (E.pushCRel env x1 d1, D.enter denv) r1 r2) + let + val denv' = D.enter denv + (*val befor = Time.now ()*) + val env' = E.pushCRel env x1 d1 + in + (*TextIO.print ("E.pushCRel: " + ^ LargeReal.toString (Time.toReal (Time.- (Time.now (), befor))) + ^ "\n");*) + unifyCons' (env', denv') r1 r2 + end) | (L'.TRecord r1, L'.TRecord r2) => unifyCons' (env, denv) r1 r2 | (L'.CRel n1, L'.CRel n2) => @@ -1478,6 +1494,7 @@ val makeInstantiable = fun elabExp (env, denv) (eAll as (e, loc)) = let (*val () = eprefaces "elabExp" [("eAll", SourcePrint.p_exp eAll)];*) + (*val befor = Time.now ()*) val r = case e of L.EAnnot (e, t) => @@ -1770,7 +1787,7 @@ fun elabExp (env, denv) (eAll as (e, loc)) = end in (*prefaces "elabExp" [("e", SourcePrint.p_exp eAll), - ("t", PD.string (LargeInt.toString (Time.toMilliseconds (Time.- (Time.now (), befor)))))];*) + ("t", PD.string (LargeReal.toString (Time.toReal (Time.- (Time.now (), befor)))))];*) r end @@ -2913,6 +2930,7 @@ fun wildifyStr env (str, sgn) = fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = let (*val () = preface ("elabDecl", SourcePrint.p_decl (d, loc))*) + (*val befor = Time.now ()*) val r = case d of @@ -3293,8 +3311,8 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) in (*prefaces "elabDecl" [("e", SourcePrint.p_decl dAll), - ("t", PD.string (LargeInt.toString (Time.toMilliseconds - (Time.- (Time.now (), befor)))))];*) + ("t", PD.string (LargeReal.toString (Time.toReal + (Time.- (Time.now (), befor)))))];*) r end -- cgit v1.2.3 From ca833ef09c3bbb51e38b98f70c480a767c83c829 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 27 Nov 2008 10:46:45 -0500 Subject: Stop using redundant Defunc pass --- src/compiler.sig | 3 --- src/compiler.sml | 12 +----------- 2 files changed, 1 insertion(+), 14 deletions(-) diff --git a/src/compiler.sig b/src/compiler.sig index 8c52ea32..59ad32be 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -66,7 +66,6 @@ signature COMPILER = sig val especialize : (Core.file, Core.file) phase val core_untangle : (Core.file, Core.file) phase val shake : (Core.file, Core.file) phase - val defunc : (Core.file, Core.file) phase val tag : (Core.file, Core.file) phase val reduce : (Core.file, Core.file) phase val unpoly : (Core.file, Core.file) phase @@ -92,8 +91,6 @@ signature COMPILER = sig val toEspecialize : (string, Core.file) transform val toCore_untangle : (string, Core.file) transform val toShake1 : (string, Core.file) transform - val toDefunc : (string, Core.file) transform - val toShake1' : (string, Core.file) transform val toTag : (string, Core.file) transform val toReduce : (string, Core.file) transform val toUnpoly : (string, Core.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index aac4a924..0ff4ee6a 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -446,22 +446,12 @@ val shake = { val toShake1 = transform shake "shake1" o toCore_untangle -val defunc = { - func = Defunc.defunc, - print = CorePrint.p_file CoreEnv.empty -} - -val toDefunc = transform defunc "defunc" o toShake1 - -val toCore_untangle' = transform core_untangle "core_untangle'" o toDefunc -val toShake1' = transform shake "shake1'" o toCore_untangle' - val tag = { func = Tag.tag, print = CorePrint.p_file CoreEnv.empty } -val toTag = transform tag "tag" o toShake1' +val toTag = transform tag "tag" o toShake1 val reduce = { func = Reduce.reduce, -- cgit v1.2.3 From faa82a140dbd3af5a59f489177ab6d43dca0ccf1 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 27 Nov 2008 10:57:56 -0500 Subject: Optimized ElabOps.subConInCon --- src/elab_ops.sml | 40 ++++++++++++++++++++++++++++------------ 1 file changed, 28 insertions(+), 12 deletions(-) diff --git a/src/elab_ops.sml b/src/elab_ops.sml index 5102d0ab..0648d704 100644 --- a/src/elab_ops.sml +++ b/src/elab_ops.sml @@ -32,22 +32,38 @@ open Elab structure E = ElabEnv structure U = ElabUtil -val liftConInCon = E.liftConInCon +fun liftConInCon by = + U.Con.mapB {kind = fn k => k, + con = fn bound => fn c => + case c of + CRel xn => + if xn < bound then + c + else + CRel (xn + by) + (*| CUnif _ => raise SynUnif*) + | _ => c, + bind = fn (bound, U.Con.Rel _) => bound + 1 + | (bound, _) => bound} -val subConInCon = +fun subConInCon' rep = U.Con.mapB {kind = fn k => k, - con = fn (xn, rep) => fn c => - case c of - CRel xn' => - (case Int.compare (xn', xn) of - EQUAL => #1 rep - | GREATER => CRel (xn' - 1) - | LESS => c) - (*| CUnif _ => raise SynUnif*) - | _ => c, - bind = fn ((xn, rep), U.Con.Rel _) => (xn+1, liftConInCon 0 rep) + con = fn (by, xn) => fn c => + case c of + CRel xn' => + (case Int.compare (xn', xn) of + EQUAL => #1 (liftConInCon by 0 rep) + | GREATER => CRel (xn' - 1) + | LESS => c) + (*| CUnif _ => raise SynUnif*) + | _ => c, + bind = fn ((by, xn), U.Con.Rel _) => (by+1, xn+1) | (ctx, _) => ctx} +val liftConInCon = liftConInCon 1 + +fun subConInCon (xn, rep) = subConInCon' rep (0, xn) + fun subStrInSgn (m1, m2) = U.Sgn.map {kind = fn k => k, con = fn c as CModProj (m1', ms, x) => -- cgit v1.2.3 From efa3df8ba3084f1b494e2ce6ba4a355c00ee9d8c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 27 Nov 2008 11:06:10 -0500 Subject: Catch another unneeded lift in ElabEnv.pushCRel --- src/elab_env.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/elab_env.sml b/src/elab_env.sml index 3acb855d..d1084d0c 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -281,7 +281,7 @@ fun pushCRel (env : env) x k = (#classes env), renameE = SM.map (fn Rel' (n, c) => Rel' (n, lift c) - | Named' (n, c) => Named' (n, lift c)) (#renameE env), + | Named' (n, c) => Named' (n, c)) (#renameE env), relE = map (fn (x, c) => (x, lift c)) (#relE env), namedE = #namedE env, -- cgit v1.2.3 From a2ed8473fed8d9be0d4640bd9973c89d3424acf5 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 27 Nov 2008 11:17:56 -0500 Subject: Remove some isUnitCon cases --- src/elaborate.sml | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/elaborate.sml b/src/elaborate.sml index 86ae6067..d42175ce 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -548,8 +548,8 @@ | L'.CRel xn => #1 (#2 (E.lookupCRel env xn)) = L'.KUnit | L'.CNamed xn => #1 (#2 (E.lookupCNamed env xn)) = L'.KUnit - | L'.CModProj (n, ms, x) => - let + | L'.CModProj (n, ms, x) => false + (*let val (_, sgn) = E.lookupStrNamed env n val (str, sgn) = foldl (fn (m, (str, sgn)) => case E.projectStr env {sgn = sgn, str = str, field = m} of @@ -560,15 +560,15 @@ case E.projectCon env {sgn = sgn, str = str, field = x} of NONE => raise Fail "kindof: Unknown con in structure" | SOME ((k, _), _) => k = L'.KUnit - end + end*) - | L'.CApp (c, _) => - (case hnormKind (kindof env c) of + | L'.CApp (c, _) => false + (*(case hnormKind (kindof env c) of (L'.KArrow (_, k), _) => #1 k = L'.KUnit | (L'.KError, _) => false - | k => raise CUnify' (CKindof (k, c, "arrow"))) + | k => raise CUnify' (CKindof (k, c, "arrow")))*) | L'.CAbs _ => false - | L'.CDisjoint (_, _, _, c) => isUnitCon env c + | L'.CDisjoint (_, _, _, c) => false(*isUnitCon env c*) | L'.CName _ => false @@ -579,10 +579,10 @@ | L'.CUnit => true | L'.CTuple _ => false - | L'.CProj (c, n) => - (case hnormKind (kindof env c) of + | L'.CProj (c, n) => false + (*(case hnormKind (kindof env c) of (L'.KTuple ks, _) => #1 (List.nth (ks, n - 1)) = L'.KUnit - | k => raise CUnify' (CKindof (k, c, "tuple"))) + | k => raise CUnify' (CKindof (k, c, "tuple")))*) | L'.CError => false | L'.CUnif (_, k, _, _) => #1 k = L'.KUnit -- cgit v1.2.3 From 93d666ff22896de47c8e6b93a338004ddecdcfdb Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 27 Nov 2008 11:40:13 -0500 Subject: Optimize CoreUntangle --- src/core_untangle.sml | 51 ++++++++++++++++++++------------------------------- 1 file changed, 20 insertions(+), 31 deletions(-) diff --git a/src/core_untangle.sml b/src/core_untangle.sml index ededded0..1b34fe8f 100644 --- a/src/core_untangle.sml +++ b/src/core_untangle.sml @@ -37,22 +37,21 @@ structure IM = IntBinaryMap fun default (k, s) = s -fun exp (e, s) = +fun exp thisGroup (e, s) = case e of - ENamed n => IS.add (s, n) + ENamed n => + if IS.member (thisGroup, n) then + IS.add (s, n) + else + s | _ => s fun untangle file = let - val edefs = foldl (fn ((d, _), edefs) => - case d of - DVal (_, n, _, e, _) => IM.insert (edefs, n, e) - | DValRec vis => - foldl (fn ((_, n, _, e, _), edefs) => - IM.insert (edefs, n, e)) edefs vis - | _ => edefs) - IM.empty file + fun expUsed thisGroup = U.Exp.fold {con = default, + kind = default, + exp = exp thisGroup} IS.empty fun decl (dAll as (d, loc)) = case d of @@ -61,35 +60,23 @@ fun untangle file = val thisGroup = foldl (fn ((_, n, _, _, _), thisGroup) => IS.add (thisGroup, n)) IS.empty vis - val expUsed = U.Exp.fold {con = default, - kind = default, - exp = exp} IS.empty + val edefs = foldl (fn ((_, n, _, e, _), edefs) => + IM.insert (edefs, n, expUsed thisGroup e)) + IM.empty vis - val used = foldl (fn ((_, n, _, e, _), used) => - let - val usedHere = expUsed e - in - IM.insert (used, n, usedHere) - end) - IM.empty vis + val used = edefs fun expand used = IS.foldl (fn (n, used) => case IM.find (edefs, n) of NONE => used - | SOME e => - let - val usedHere = expUsed e - in - if IS.isEmpty (IS.difference (usedHere, used)) then - used - else - expand (IS.union (usedHere, used)) - end) + | SOME usedHere => + if IS.isEmpty (IS.difference (usedHere, used)) then + used + else + expand (IS.union (usedHere, used))) used used - val used = IM.map (fn s => IS.intersection (expand s, thisGroup)) used - fun p_graph reachable = IM.appi (fn (n, reachableHere) => (print (Int.toString n); @@ -164,6 +151,7 @@ fun untangle file = end val sccs = sccs (thisGroup, []) + (*val () = app (fn nodes => (print "SCC:"; IS.app (fn i => (print " "; print (Int.toString i))) nodes; @@ -199,6 +187,7 @@ fun untangle file = end val sccs = topo (sccs, []) + (*val () = app (fn nodes => (print "SCC':"; IS.app (fn i => (print " "; print (Int.toString i))) nodes; -- cgit v1.2.3 From 17260c1fcb1778217df23b5e1c1271642d8aab80 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 27 Nov 2008 12:04:54 -0500 Subject: Untangle and shake within Especialize loop --- src/especialize.sml | 15 +++++++++++---- src/sources | 6 +++--- 2 files changed, 14 insertions(+), 7 deletions(-) diff --git a/src/especialize.sml b/src/especialize.sml index 220b48bd..c2a763ea 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -349,15 +349,22 @@ fun specialize' file = fun specialize file = let (*val () = Print.prefaces "Intermediate" [("file", CorePrint.p_file CoreEnv.empty file)];*) - val file = ReduceLocal.reduce file + (*val file = ReduceLocal.reduce file*) val (changed, file) = specialize' file - val file = ReduceLocal.reduce file - (*val file = CoreUntangle.untangle file + (*val file = ReduceLocal.reduce file + val file = CoreUntangle.untangle file val file = Shake.shake file*) in (*print "Round over\n";*) if changed then - specialize file + let + val file = ReduceLocal.reduce file + val file = CoreUntangle.untangle file + val file = Shake.shake file + in + (*print "Again!\n";*) + specialize file + end else file end diff --git a/src/sources b/src/sources index 13f505d0..6972dc36 100644 --- a/src/sources +++ b/src/sources @@ -99,12 +99,12 @@ specialize.sml reduce_local.sig reduce_local.sml -especialize.sig -especialize.sml - core_untangle.sig core_untangle.sml +especialize.sig +especialize.sml + defunc.sig defunc.sml -- cgit v1.2.3 From 82dca6c875cca25d05dfbd5c6a2fb2185b965692 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 27 Nov 2008 12:34:44 -0500 Subject: Ditch use of ElabEnv.env in Especialize, to realize big speed-up --- src/especialize.sml | 33 +++++++++++++++++---------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/src/especialize.sml b/src/especialize.sml index c2a763ea..335401fe 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -104,7 +104,7 @@ type state = { decls : (string * int * con * exp * string) list } -fun kind x = x +fun id x = x fun default (_, x, st) = (x, st) fun specialize' file = @@ -140,10 +140,8 @@ fun specialize' file = fun bind (env, b) = case b of - U.Decl.RelC (x, k) => E.pushCRel env x k - | U.Decl.NamedC (x, n, k, co) => E.pushCNamed env x n k co - | U.Decl.RelE (x, t) => E.pushERel env x t - | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s + U.Decl.RelE xt => xt :: env + | _ => env fun exp (env, e, st : state) = let @@ -249,7 +247,7 @@ fun specialize' file = ("e", CorePrint.p_exp env (e, loc))]*) val (body', typ') = IS.foldl (fn (n, (body', typ')) => let - val (x, xt) = E.lookupERel env n + val (x, xt) = List.nth (env, n) in ((EAbs (x, xt, typ', body'), loc), @@ -277,13 +275,13 @@ fun specialize' file = end end - and specExp env = U.Exp.foldMapB {kind = kind, con = default, exp = exp, bind = bind} env + and specExp env = U.Exp.foldMapB {kind = id, con = default, exp = exp, bind = bind} env - val specDecl = U.Decl.foldMapB {kind = kind, con = default, exp = exp, decl = default, bind = bind} + val specDecl = U.Decl.foldMapB {kind = id, con = default, exp = exp, decl = default, bind = bind} - fun doDecl (d, (env, st : state, changed)) = + fun doDecl (d, (st : state, changed)) = let - val env = E.declBinds env d + (*val befor = Time.now ()*) val funcs = #funcs st val funcs = @@ -303,7 +301,9 @@ fun specialize' file = decls = []} (*val () = Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)]*) - val (d', st) = specDecl env st d + + val (d', st) = specDecl [] st d + (*val () = print "/decl\n"*) val funcs = #funcs st @@ -329,15 +329,16 @@ fun specialize' file = (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)] | _ => [(DValRec vis, ErrorMsg.dummySpan), d']) in - (ds, (env, - {maxName = #maxName st, + (*Print.prefaces "doDecl" [("d", CorePrint.p_decl E.empty d), + ("t", Print.PD.string (Real.toString (Time.toReal + (Time.- (Time.now (), befor)))))];*) + (ds, ({maxName = #maxName st, funcs = funcs, decls = []}, changed)) end - val (ds, (_, _, changed)) = ListUtil.foldlMapConcat doDecl - (E.empty, - {maxName = U.File.maxName file + 1, + val (ds, (_, changed)) = ListUtil.foldlMapConcat doDecl + ({maxName = U.File.maxName file + 1, funcs = IM.empty, decls = []}, false) -- cgit v1.2.3 From 960a42fc1844d5f0f6033b3caada6349d588a2a9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 27 Nov 2008 12:43:28 -0500 Subject: Avoid Especializing polymorphic code --- src/core_util.sig | 5 +++++ src/core_util.sml | 24 ++++++++++++++++++++++++ src/especialize.sml | 12 +++++++++++- 3 files changed, 40 insertions(+), 1 deletion(-) diff --git a/src/core_util.sig b/src/core_util.sig index 39f50cc1..fc5a2bea 100644 --- a/src/core_util.sig +++ b/src/core_util.sig @@ -165,6 +165,11 @@ structure Decl : sig decl : 'context * Core.decl' * 'state -> Core.decl' * 'state, bind : 'context * binder -> 'context} -> 'context -> 'state -> Core.decl -> Core.decl * 'state + + val exists : {kind : Core.kind' -> bool, + con : Core.con' -> bool, + exp : Core.exp' -> bool, + decl : Core.decl' -> bool} -> Core.decl -> bool end structure File : sig diff --git a/src/core_util.sml b/src/core_util.sml index 71efe16e..02cb86ca 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -900,6 +900,30 @@ fun foldMapB {kind, con, exp, decl, bind} ctx s d = S.Continue v => v | S.Return _ => raise Fail "CoreUtil.Decl.foldMapB: Impossible" +fun exists {kind, con, exp, decl} d = + case mapfold {kind = fn k => fn () => + if kind k then + S.Return () + else + S.Continue (k, ()), + con = fn c => fn () => + if con c then + S.Return () + else + S.Continue (c, ()), + exp = fn e => fn () => + if exp e then + S.Return () + else + S.Continue (e, ()), + decl = fn d => fn () => + if decl d then + S.Return () + else + S.Continue (d, ())} d () of + S.Return _ => true + | S.Continue _ => false + end structure File = struct diff --git a/src/especialize.sml b/src/especialize.sml index 335401fe..7abc0582 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -59,6 +59,12 @@ val freeVars = U.Exp.foldB {kind = fn (_, xs) => xs, | _ => bound} 0 IS.empty +val isPoly = U.Decl.exists {kind = fn _ => false, + con = fn _ => false, + exp = fn ECAbs _ => true + | _ => false, + decl = fn _ => false} + fun positionOf (v : int, ls) = let fun pof (pos, ls) = @@ -302,7 +308,11 @@ fun specialize' file = (*val () = Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)]*) - val (d', st) = specDecl [] st d + val (d', st) = + if isPoly d then + (d, st) + else + specDecl [] st d (*val () = print "/decl\n"*) -- cgit v1.2.3 From df08dfc3be26b2cf829a1ea31b63f4aaecf1f3bf Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 27 Nov 2008 13:43:15 -0500 Subject: Note optimizations in changelog --- CHANGELOG | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG b/CHANGELOG index cbd67118..a620eb3c 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -2,6 +2,7 @@ ======== - Optimization: Fusing page writes with calls to recursive functions +- Optimization of bottleneck compiler phases ======== 20081120 -- cgit v1.2.3 From 61bd40e1af8c3f7ace2a09068557ac7c05662b69 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 27 Nov 2008 14:38:53 -0500 Subject: Start of manual --- .hgignore | 7 ++++- CHANGELOG | 1 + doc/Makefile | 23 ++++++++++++++++ doc/manual.tex | 85 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 115 insertions(+), 1 deletion(-) create mode 100644 doc/Makefile create mode 100644 doc/manual.tex diff --git a/.hgignore b/.hgignore index b388b26a..fe5b6659 100644 --- a/.hgignore +++ b/.hgignore @@ -13,7 +13,7 @@ src/urweb.mlb *.grm.* *.o -Makefile +./Makefile src/config.sml *.exe @@ -27,3 +27,8 @@ demo/demo.* *.sql *mlmon.out + +*.aux +*.dvi +*.pdf +*.ps diff --git a/CHANGELOG b/CHANGELOG index a620eb3c..7ba7088e 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -3,6 +3,7 @@ - Optimization: Fusing page writes with calls to recursive functions - Optimization of bottleneck compiler phases +- Start of manual ======== 20081120 diff --git a/doc/Makefile b/doc/Makefile new file mode 100644 index 00000000..777c5bf7 --- /dev/null +++ b/doc/Makefile @@ -0,0 +1,23 @@ +PAPERS=manual + +FIGURES= + +all: $(PAPERS:%=%.dvi) $(PAPERS:%=%.ps) $(PAPERS:%=%.pdf) + +%.dvi: %.tex $(FIGURES:%=%.eps) + latex $< + latex $< + +%.ps: %.dvi + dvips $< -o $@ + +%.pdf: %.dvi $(FIGURES:%=%.pdf) + pdflatex $(<:%.dvi=%) + +%.pdf: %.eps + epstopdf $< + +clean: + rm -f *.aux *.bbl *.blg *.dvi *.log *.pdf *.ps + +.PHONY: all clean diff --git a/doc/manual.tex b/doc/manual.tex new file mode 100644 index 00000000..8517206a --- /dev/null +++ b/doc/manual.tex @@ -0,0 +1,85 @@ +\documentclass{article} +\usepackage{fullpage,amsmath,amssymb,proof} + +\newcommand{\cd}[1]{\texttt{#1}} +\newcommand{\mt}[1]{\mathsf{#1}} + +\newcommand{\rc}{+ \hspace{-.075in} + \;} + +\begin{document} + +\title{The Ur/Web Manual} +\author{Adam Chlipala} + +\maketitle + +\section{Syntax} + +\subsection{Lexical Conventions} + +We give the Ur language definition in \LaTeX $\;$ math mode, since that is prettier than monospaced ASCII. The corresponding ASCII syntax can be read off directly. Here is the key for mapping math symbols to ASCII character sequences. + +\begin{center} + \begin{tabular}{rl} + \textbf{\LaTeX} & \textbf{ASCII} \\ + $\to$ & \cd{->} \\ + $\times$ & \cd{*} \\ + $\lambda$ & \cd{fn} \\ + $\Rightarrow$ & \cd{=>} \\ + $\rc$ & \cd{++} \\ + \\ + $x$ & Normal textual identifier, not beginning with an uppercase letter \\ + $\alpha$ & Normal textual identifier, not beginning with an uppercase letter \\ + $f$ & Normal textual identifier, beginning with an uppercase letter \\ + \end{tabular} +\end{center} + +We often write syntax like $N, \cdots, N$ to stand for the non-terminal $N$ repeated 0 or more times. That is, the $\cdots$ symbol is not translated literally to ASCII. + +\subsection{Core Syntax} + +\emph{Kinds} classify types and other compile-time-only entities. Each kind in the grammar is listed with a description of the sort of data it classifies. +$$\begin{array}{rrcll} + \textrm{Kinds} & \kappa &::=& \mt{Type} & \textrm{proper types} \\ + &&& \mid \mt{Unit} & \textrm{the trivial constructor} \\ + &&& \mid \mt{Name} & \textrm{field names} \\ + &&& \mid \kappa \to \kappa & \textrm{type-level functions} \\ + &&& \mid \{\kappa\} & \textrm{type-level records} \\ + &&& \mid (\kappa \times \cdots \times \kappa) & \textrm{type-level tuples} \\ + &&& \mid (\kappa) & \textrm{explicit precedence} \\ +\end{array}$$ + +Ur supports several different notions of functions that take types as arguments. These arguments can be either implicit, causing them to be inferred at use sites; or explicit, forcing them to be specified manually at use sites. There is a common explicitness annotation convention applied at the definitions of and in the types of such functions. +$$\begin{array}{rrcll} + \textrm{Explicitness} & ? &::=& :: & \textrm{explicit} \\ + &&& \mid \; ::: & \textrm{implicit} +\end{array}$$ + +\emph{Constructors} are the main class of compile-time-only data. They include proper types and are classified by kinds. +$$\begin{array}{rrcll} + \textrm{Constructors} & c, \tau &::=& (c) :: \kappa & \textrm{kind annotation} \\ + &&& \mid \alpha & \textrm{constructor variable} \\ + \\ + &&& \mid \tau \to \tau & \textrm{function type} \\ + &&& \mid \alpha \; ? \; \kappa \to \tau & \textrm{polymorphic function type} \\ + &&& \mid \$ c & \textrm{record type} \\ + \\ + &&& \mid c \; c & \textrm{type-level function application} \\ + &&& \mid \lambda \alpha \; ? \; \kappa \Rightarrow c & \textrm{type-level function abstraction} \\ + \\ + &&& \mid () & \textrm{type-level unit} \\ + &&& \mid \#f & \textrm{field name} \\ + \\ + &&& \mid [c = c, \cdots, c = c] & \textrm{known-length type-level record} \\ + &&& \mid c \rc c & \textrm{type-level record concatenation} \\ + &&& \mid \mt{fold} & \textrm{type-level record fold} \\ + \\ + &&& \mid (c, \cdots, c) & \textrm{type-level tuple} \\ + &&& \mid c.n & \textrm{type-level tuple projection ($n \in \mathbb N^+$)} \\ + \\ + &&& \mid \lambda [c \sim c] \Rightarrow c & \textrm{guarded constructor} \\ + \\ + &&& \mid (c) & \textrm{explicit precedence} \\ +\end{array}$$ + +\end{document} \ No newline at end of file -- cgit v1.2.3 From 6b14029cca03a763f05baf08ce362d8a250b4288 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 27 Nov 2008 14:57:47 -0500 Subject: Signatures --- doc/manual.tex | 73 ++++++++++++++++++++++++++++++++++++++-------------------- 1 file changed, 48 insertions(+), 25 deletions(-) diff --git a/doc/manual.tex b/doc/manual.tex index 8517206a..e83dc392 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -29,57 +29,80 @@ We give the Ur language definition in \LaTeX $\;$ math mode, since that is prett $\rc$ & \cd{++} \\ \\ $x$ & Normal textual identifier, not beginning with an uppercase letter \\ - $\alpha$ & Normal textual identifier, not beginning with an uppercase letter \\ - $f$ & Normal textual identifier, beginning with an uppercase letter \\ + $X$ & Normal textual identifier, beginning with an uppercase letter \\ \end{tabular} \end{center} -We often write syntax like $N, \cdots, N$ to stand for the non-terminal $N$ repeated 0 or more times. That is, the $\cdots$ symbol is not translated literally to ASCII. +We often write syntax like $e^*$ to indicate zero or more copies of $e$, $e^+$ to indicate one or more copies, and $e,^*$ and $e,^+$ to indicate multiple copies separated by commas. Another separator may be used in place of a comma. The $e$ term may be surrounded by parentheses to indicate grouping; those parentheses should not be included in the actual ASCII. \subsection{Core Syntax} \emph{Kinds} classify types and other compile-time-only entities. Each kind in the grammar is listed with a description of the sort of data it classifies. $$\begin{array}{rrcll} \textrm{Kinds} & \kappa &::=& \mt{Type} & \textrm{proper types} \\ - &&& \mid \mt{Unit} & \textrm{the trivial constructor} \\ - &&& \mid \mt{Name} & \textrm{field names} \\ - &&& \mid \kappa \to \kappa & \textrm{type-level functions} \\ - &&& \mid \{\kappa\} & \textrm{type-level records} \\ - &&& \mid (\kappa \times \cdots \times \kappa) & \textrm{type-level tuples} \\ - &&& \mid (\kappa) & \textrm{explicit precedence} \\ + &&& \mt{Unit} & \textrm{the trivial constructor} \\ + &&& \mt{Name} & \textrm{field names} \\ + &&& \kappa \to \kappa & \textrm{type-level functions} \\ + &&& \{\kappa\} & \textrm{type-level records} \\ + &&& (\kappa\times^+) & \textrm{type-level tuples} \\ + &&& (\kappa) & \textrm{explicit precedence} \\ \end{array}$$ Ur supports several different notions of functions that take types as arguments. These arguments can be either implicit, causing them to be inferred at use sites; or explicit, forcing them to be specified manually at use sites. There is a common explicitness annotation convention applied at the definitions of and in the types of such functions. $$\begin{array}{rrcll} \textrm{Explicitness} & ? &::=& :: & \textrm{explicit} \\ - &&& \mid \; ::: & \textrm{implicit} + &&& \; ::: & \textrm{implicit} \end{array}$$ \emph{Constructors} are the main class of compile-time-only data. They include proper types and are classified by kinds. $$\begin{array}{rrcll} \textrm{Constructors} & c, \tau &::=& (c) :: \kappa & \textrm{kind annotation} \\ - &&& \mid \alpha & \textrm{constructor variable} \\ + &&& x & \textrm{constructor variable} \\ \\ - &&& \mid \tau \to \tau & \textrm{function type} \\ - &&& \mid \alpha \; ? \; \kappa \to \tau & \textrm{polymorphic function type} \\ - &&& \mid \$ c & \textrm{record type} \\ + &&& \tau \to \tau & \textrm{function type} \\ + &&& x \; ? \; \kappa \to \tau & \textrm{polymorphic function type} \\ + &&& \$ c & \textrm{record type} \\ \\ - &&& \mid c \; c & \textrm{type-level function application} \\ - &&& \mid \lambda \alpha \; ? \; \kappa \Rightarrow c & \textrm{type-level function abstraction} \\ + &&& c \; c & \textrm{type-level function application} \\ + &&& \lambda x \; ? \; \kappa \Rightarrow c & \textrm{type-level function abstraction} \\ \\ - &&& \mid () & \textrm{type-level unit} \\ - &&& \mid \#f & \textrm{field name} \\ + &&& () & \textrm{type-level unit} \\ + &&& \#X & \textrm{field name} \\ \\ - &&& \mid [c = c, \cdots, c = c] & \textrm{known-length type-level record} \\ - &&& \mid c \rc c & \textrm{type-level record concatenation} \\ - &&& \mid \mt{fold} & \textrm{type-level record fold} \\ + &&& [(c = c)^*] & \textrm{known-length type-level record} \\ + &&& c \rc c & \textrm{type-level record concatenation} \\ + &&& \mt{fold} & \textrm{type-level record fold} \\ \\ - &&& \mid (c, \cdots, c) & \textrm{type-level tuple} \\ - &&& \mid c.n & \textrm{type-level tuple projection ($n \in \mathbb N^+$)} \\ + &&& (c^+) & \textrm{type-level tuple} \\ + &&& c.n & \textrm{type-level tuple projection ($n \in \mathbb N^+$)} \\ \\ - &&& \mid \lambda [c \sim c] \Rightarrow c & \textrm{guarded constructor} \\ + &&& \lambda [c \sim c] \Rightarrow c & \textrm{guarded constructor} \\ \\ - &&& \mid (c) & \textrm{explicit precedence} \\ + &&& (c) & \textrm{explicit precedence} \\ +\end{array}$$ + +Modules of the module system are described by \emph{signatures}. +$$\begin{array}{rrcll} + \textrm{Signatures} & S &::=& \mt{sig} \; s^* \; \mt{end} & \textrm{constant} \\ + &&& X & \textrm{variable} \\ + &&& \mt{functor}(X : S) : S & \textrm{functor} \\ + &&& S \; \mt{where} \; x = c & \textrm{concretizing an abstract constructor} \\ + &&& M.X & \textrm{projection from a module} \\ + \\ + \textrm{Signature items} & s &::=& \mt{con} \; x :: \kappa & \textrm{abstract constructor} \\ + &&& \mt{con} \; x :: \kappa = c & \textrm{concrete constructor} \\ + &&& \mt{datatype} \; x \; x^* = dc\mid^+ & \textrm{algebraic datatype declaration} \\ + &&& \mt{datatype} \; x = M.x & \textrm{algebraic datatype import} \\ + &&& \mt{val} \; x : \tau & \textrm{value} \\ + &&& \mt{structure} \; X : S & \textrm{sub-module} \\ + &&& \mt{signature} \; X = S & \textrm{sub-signature} \\ + &&& \mt{include} \; S & \textrm{signature inclusion} \\ + &&& \mt{constraint} \; c \sim c & \textrm{record disjointness constraint} \\ + &&& \mt{class} \; x & \textrm{abstract type class} \\ + &&& \mt{class} \; x = c & \textrm{concrete type class} \\ + \\ + \textrm{Datatype constructors} & dc &::=& X & \textrm{nullary constructor} \\ + &&& X \; \mt{of} \; \tau & \textrm{unary constructor} \\ \end{array}$$ \end{document} \ No newline at end of file -- cgit v1.2.3 From a9c2432822c68cfc0897c162b17af6b69d0e22b7 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 27 Nov 2008 15:06:29 -0500 Subject: Patterns --- doc/manual.tex | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/doc/manual.tex b/doc/manual.tex index e83dc392..01f5a5f3 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -35,6 +35,8 @@ We give the Ur language definition in \LaTeX $\;$ math mode, since that is prett We often write syntax like $e^*$ to indicate zero or more copies of $e$, $e^+$ to indicate one or more copies, and $e,^*$ and $e,^+$ to indicate multiple copies separated by commas. Another separator may be used in place of a comma. The $e$ term may be surrounded by parentheses to indicate grouping; those parentheses should not be included in the actual ASCII. +We write $\ell$ for literals of the primitive types, for the most part following C conventions. There are $\mt{int}$, $\mt{float}$, and $\mt{string}$ literals. + \subsection{Core Syntax} \emph{Kinds} classify types and other compile-time-only entities. Each kind in the grammar is listed with a description of the sort of data it classifies. @@ -105,4 +107,18 @@ $$\begin{array}{rrcll} &&& X \; \mt{of} \; \tau & \textrm{unary constructor} \\ \end{array}$$ +\emph{Patterns} are used to describe structural conditions on expressions, such that expressions may be tested against patterns, generating assignments to pattern variables if successful. +$$\begin{array}{rrcll} + \textrm{Patterns} & p &::=& \_ & \textrm{wildcard} \\ + &&& x & \textrm{variable} \\ + &&& \ell & \textrm{constant} \\ + &&& \hat{X} & \textrm{nullary constructor} \\ + &&& \hat{X} \; p & \textrm{unary constructor} \\ + &&& \{(x = p,)^*\} & \textrm{rigid record pattern} \\ + &&& \{(x = p,)^+, \ldots\} & \textrm{flexible record pattern} \\ + \\ + \textrm{Qualified capitalized variable} & \hat{X} &::=& X & \textrm{not from a module} \\ + &&& M.X & \textrm{projection from a module} \\ +\end{array}$$ + \end{document} \ No newline at end of file -- cgit v1.2.3 From 5e3c42711e20b42ba7f850cc5800f01cbfee3f05 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 27 Nov 2008 15:27:17 -0500 Subject: Expressions --- doc/manual.tex | 41 ++++++++++++++++++++++++++++++++++++++++- 1 file changed, 40 insertions(+), 1 deletion(-) diff --git a/doc/manual.tex b/doc/manual.tex index 01f5a5f3..18879a50 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -5,6 +5,8 @@ \newcommand{\mt}[1]{\mathsf{#1}} \newcommand{\rc}{+ \hspace{-.075in} + \;} +\newcommand{\rcut}{\; \texttt{--} \;} +\newcommand{\rcutM}{\; \texttt{---} \;} \begin{document} @@ -26,7 +28,7 @@ We give the Ur language definition in \LaTeX $\;$ math mode, since that is prett $\times$ & \cd{*} \\ $\lambda$ & \cd{fn} \\ $\Rightarrow$ & \cd{=>} \\ - $\rc$ & \cd{++} \\ + & \cd{---} \\ \\ $x$ & Normal textual identifier, not beginning with an uppercase letter \\ $X$ & Normal textual identifier, beginning with an uppercase letter \\ @@ -37,6 +39,8 @@ We often write syntax like $e^*$ to indicate zero or more copies of $e$, $e^+$ t We write $\ell$ for literals of the primitive types, for the most part following C conventions. There are $\mt{int}$, $\mt{float}$, and $\mt{string}$ literals. +This version of the manual doesn't include operator precedences; see \texttt{src/urweb.grm} for that. + \subsection{Core Syntax} \emph{Kinds} classify types and other compile-time-only entities. Each kind in the grammar is listed with a description of the sort of data it classifies. @@ -47,6 +51,7 @@ $$\begin{array}{rrcll} &&& \kappa \to \kappa & \textrm{type-level functions} \\ &&& \{\kappa\} & \textrm{type-level records} \\ &&& (\kappa\times^+) & \textrm{type-level tuples} \\ + &&& \_ & \textrm{wildcard} \\ &&& (\kappa) & \textrm{explicit precedence} \\ \end{array}$$ @@ -80,6 +85,7 @@ $$\begin{array}{rrcll} \\ &&& \lambda [c \sim c] \Rightarrow c & \textrm{guarded constructor} \\ \\ + &&& \_ & \textrm{wildcard} \\ &&& (c) & \textrm{explicit precedence} \\ \end{array}$$ @@ -116,9 +122,42 @@ $$\begin{array}{rrcll} &&& \hat{X} \; p & \textrm{unary constructor} \\ &&& \{(x = p,)^*\} & \textrm{rigid record pattern} \\ &&& \{(x = p,)^+, \ldots\} & \textrm{flexible record pattern} \\ + &&& (p) & \textrm{explicit precedence} \\ \\ \textrm{Qualified capitalized variable} & \hat{X} &::=& X & \textrm{not from a module} \\ &&& M.X & \textrm{projection from a module} \\ \end{array}$$ +\emph{Expressions} are the main run-time entities, corresponding to both ``expressions'' and ``statements'' in mainstream imperative languages. +$$\begin{array}{rrcll} + \textrm{Expressions} & e &::=& e : \tau & \textrm{type annotation} \\ + &&& x & \textrm{variable} \\ + &&& \ell & \textrm{constant} \\ + \\ + &&& e \; e & \textrm{function application} \\ + &&& \lambda x : \tau \Rightarrow e & \textrm{function abstraction} \\ + &&& e [c] & \textrm{polymorphic function application} \\ + &&& \lambda x \; ? \; \kappa \Rightarrow e & \textrm{polymorphic function abstraction} \\ + \\ + &&& \{(c = e,)^*\} & \textrm{known-length record} \\ + &&& e.c & \textrm{record field projection} \\ + &&& e \rc e & \textrm{record concatenation} \\ + &&& e \rcut c & \textrm{removal of a single record field} \\ + &&& e \rcutM c & \textrm{removal of multiple record fields} \\ + &&& \mt{fold} & \textrm{fold over fields of a type-level record} \\ + \\ + &&& \mt{let} \; ed^* \; \mt{in} \; e \; \mt{end} & \textrm{local definitions} \\ + \\ + &&& \mt{case} \; e \; \mt{of} \; (p \Rightarrow e|)^+ & \textrm{pattern matching} \\ + \\ + &&& \lambda [c \sim c] \Rightarrow e & \textrm{guarded expression} \\ + \\ + &&& \_ & \textrm{wildcard} \\ + &&& (e) & \textrm{explicit precedence} \\ + \\ + \textrm{Local declarations} & ed &::=& \cd{val} \; x : \tau = e & \textrm{non-recursive value} \\ + &&& \cd{val} \; \cd{rec} \; (x : \tau = e \; \cd{and})^+ & \textrm{mutually-recursive values} \\ +\end{array}$$ + + \end{document} \ No newline at end of file -- cgit v1.2.3 From 5f87548c461b829071799d897bd10e5cd4a557a4 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 27 Nov 2008 15:43:10 -0500 Subject: Declarations and modules --- doc/manual.tex | 27 ++++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) diff --git a/doc/manual.tex b/doc/manual.tex index 18879a50..b1042fdb 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -99,7 +99,7 @@ $$\begin{array}{rrcll} \\ \textrm{Signature items} & s &::=& \mt{con} \; x :: \kappa & \textrm{abstract constructor} \\ &&& \mt{con} \; x :: \kappa = c & \textrm{concrete constructor} \\ - &&& \mt{datatype} \; x \; x^* = dc\mid^+ & \textrm{algebraic datatype declaration} \\ + &&& \mt{datatype} \; x \; x^* = dc\mid^+ & \textrm{algebraic datatype definition} \\ &&& \mt{datatype} \; x = M.x & \textrm{algebraic datatype import} \\ &&& \mt{val} \; x : \tau & \textrm{value} \\ &&& \mt{structure} \; X : S & \textrm{sub-module} \\ @@ -159,5 +159,30 @@ $$\begin{array}{rrcll} &&& \cd{val} \; \cd{rec} \; (x : \tau = e \; \cd{and})^+ & \textrm{mutually-recursive values} \\ \end{array}$$ +\emph{Declarations} primarily bring new symbols into context. +$$\begin{array}{rrcll} + \textrm{Declarations} & d &::=& \mt{con} \; x :: \kappa = c & \textrm{constructor synonym} \\ + &&& \mt{datatype} \; x \; x^* = dc\mid^+ & \textrm{algebraic datatype definition} \\ + &&& \mt{datatype} \; x = M.x & \textrm{algebraic datatype import} \\ + &&& \mt{val} \; x : \tau = e & \textrm{value} \\ + &&& \mt{val} \; \cd{rec} \; (x : \tau = e \; \mt{and})^+ & \textrm{mutually-recursive values} \\ + &&& \mt{structure} \; X : S = M & \textrm{module definition} \\ + &&& \mt{signature} \; X = S & \textrm{signature definition} \\ + &&& \mt{open} \; M & \textrm{module inclusion} \\ + &&& \mt{constraint} \; c \sim c & \textrm{record disjointness constraint} \\ + &&& \mt{open} \; \mt{constraints} \; M & \textrm{inclusion of just the constraints from a module} \\ + &&& \mt{table} \; x : c & \textrm{SQL table} \\ + &&& \mt{sequence} \; x & \textrm{SQL sequence} \\ + &&& \mt{class} \; x = c & \textrm{concrete type class} \\ + &&& \mt{cookie} \; x : c & \textrm{HTTP cookie} \\ + \\ + \textrm{Modules} & M &::=& \mt{struct} \; d^* \; \mt{end} & \mt{constant} \\ + &&& X & \mt{variable} \\ + &&& M.X & \mt{projection} \\ + &&& M(M) & \mt{functor application} \\ + &&& \mt{functor}(X : S) : S = M & \mt{functor abstraction} \\ +\end{array}$$ + +There are two kinds of Ur files. A file named $M\texttt{.ur}$ is an \emph{implementation file}, and it should contain a sequence of declarations $d^*$. A file named $M\texttt{.urs}$ is an \emph{interface file}; it must always have a matching $M\texttt{.ur}$ and should contain a sequence of signature items $s^*$. When both files are present, the overall effect is the same as a monolithic declaration $\mt{structure} \; M : \mt{sig} \; s^* \; \mt{end} = \mt{struct} \; d^* \; \mt{end}$. When no interface file is included, the overall effect is similar, with a signature for module $M$ being inferred rather than just checked against an interface. \end{document} \ No newline at end of file -- cgit v1.2.3 From e5d50c25383c90543455c6977270c3a675f888d4 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 27 Nov 2008 16:55:30 -0500 Subject: Shorthands --- doc/manual.tex | 74 ++++++++++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 59 insertions(+), 15 deletions(-) diff --git a/doc/manual.tex b/doc/manual.tex index b1042fdb..9a2f4173 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -15,7 +15,9 @@ \maketitle -\section{Syntax} +\section{Ur Syntax} + +In this section, we describe the syntax of Ur, deferring to a later section discussion of most of the syntax specific to SQL and XML. The sole exceptions are the declaration forms for tables, sequences, and cookies. \subsection{Lexical Conventions} @@ -28,7 +30,9 @@ We give the Ur language definition in \LaTeX $\;$ math mode, since that is prett $\times$ & \cd{*} \\ $\lambda$ & \cd{fn} \\ $\Rightarrow$ & \cd{=>} \\ - & \cd{---} \\ + $\neq$ & \cd{<>} \\ + $\leq$ & \cd{<=} \\ + $\geq$ & \cd{>=} \\ \\ $x$ & Normal textual identifier, not beginning with an uppercase letter \\ $X$ & Normal textual identifier, beginning with an uppercase letter \\ @@ -51,7 +55,7 @@ $$\begin{array}{rrcll} &&& \kappa \to \kappa & \textrm{type-level functions} \\ &&& \{\kappa\} & \textrm{type-level records} \\ &&& (\kappa\times^+) & \textrm{type-level tuples} \\ - &&& \_ & \textrm{wildcard} \\ + &&& \_\_ & \textrm{wildcard} \\ &&& (\kappa) & \textrm{explicit precedence} \\ \end{array}$$ @@ -85,7 +89,7 @@ $$\begin{array}{rrcll} \\ &&& \lambda [c \sim c] \Rightarrow c & \textrm{guarded constructor} \\ \\ - &&& \_ & \textrm{wildcard} \\ + &&& \_ :: \kappa & \textrm{wildcard} \\ &&& (c) & \textrm{explicit precedence} \\ \end{array}$$ @@ -94,13 +98,13 @@ $$\begin{array}{rrcll} \textrm{Signatures} & S &::=& \mt{sig} \; s^* \; \mt{end} & \textrm{constant} \\ &&& X & \textrm{variable} \\ &&& \mt{functor}(X : S) : S & \textrm{functor} \\ - &&& S \; \mt{where} \; x = c & \textrm{concretizing an abstract constructor} \\ + &&& S \; \mt{where} \; \mt{con} \; x = c & \textrm{concretizing an abstract constructor} \\ &&& M.X & \textrm{projection from a module} \\ \\ \textrm{Signature items} & s &::=& \mt{con} \; x :: \kappa & \textrm{abstract constructor} \\ &&& \mt{con} \; x :: \kappa = c & \textrm{concrete constructor} \\ &&& \mt{datatype} \; x \; x^* = dc\mid^+ & \textrm{algebraic datatype definition} \\ - &&& \mt{datatype} \; x = M.x & \textrm{algebraic datatype import} \\ + &&& \mt{datatype} \; x = \mt{datatype} \; M.x & \textrm{algebraic datatype import} \\ &&& \mt{val} \; x : \tau & \textrm{value} \\ &&& \mt{structure} \; X : S & \textrm{sub-module} \\ &&& \mt{signature} \; X = S & \textrm{sub-signature} \\ @@ -124,14 +128,15 @@ $$\begin{array}{rrcll} &&& \{(x = p,)^+, \ldots\} & \textrm{flexible record pattern} \\ &&& (p) & \textrm{explicit precedence} \\ \\ - \textrm{Qualified capitalized variable} & \hat{X} &::=& X & \textrm{not from a module} \\ + \textrm{Qualified capitalized variables} & \hat{X} &::=& X & \textrm{not from a module} \\ &&& M.X & \textrm{projection from a module} \\ \end{array}$$ \emph{Expressions} are the main run-time entities, corresponding to both ``expressions'' and ``statements'' in mainstream imperative languages. $$\begin{array}{rrcll} \textrm{Expressions} & e &::=& e : \tau & \textrm{type annotation} \\ - &&& x & \textrm{variable} \\ + &&& \hat{x} & \textrm{variable} \\ + &&& \hat{X} & \textrm{datatype constructor} \\ &&& \ell & \textrm{constant} \\ \\ &&& e \; e & \textrm{function application} \\ @@ -157,13 +162,16 @@ $$\begin{array}{rrcll} \\ \textrm{Local declarations} & ed &::=& \cd{val} \; x : \tau = e & \textrm{non-recursive value} \\ &&& \cd{val} \; \cd{rec} \; (x : \tau = e \; \cd{and})^+ & \textrm{mutually-recursive values} \\ + \\ + \textrm{Qualified uncapitalized variables} & \hat{x} &::=& x & \textrm{not from a module} \\ + &&& M.x & \textrm{projection from a module} \\ \end{array}$$ \emph{Declarations} primarily bring new symbols into context. $$\begin{array}{rrcll} \textrm{Declarations} & d &::=& \mt{con} \; x :: \kappa = c & \textrm{constructor synonym} \\ &&& \mt{datatype} \; x \; x^* = dc\mid^+ & \textrm{algebraic datatype definition} \\ - &&& \mt{datatype} \; x = M.x & \textrm{algebraic datatype import} \\ + &&& \mt{datatype} \; x = \mt{datatype} \; M.x & \textrm{algebraic datatype import} \\ &&& \mt{val} \; x : \tau = e & \textrm{value} \\ &&& \mt{val} \; \cd{rec} \; (x : \tau = e \; \mt{and})^+ & \textrm{mutually-recursive values} \\ &&& \mt{structure} \; X : S = M & \textrm{module definition} \\ @@ -174,15 +182,51 @@ $$\begin{array}{rrcll} &&& \mt{table} \; x : c & \textrm{SQL table} \\ &&& \mt{sequence} \; x & \textrm{SQL sequence} \\ &&& \mt{class} \; x = c & \textrm{concrete type class} \\ - &&& \mt{cookie} \; x : c & \textrm{HTTP cookie} \\ + &&& \mt{cookie} \; x : \tau & \textrm{HTTP cookie} \\ \\ - \textrm{Modules} & M &::=& \mt{struct} \; d^* \; \mt{end} & \mt{constant} \\ - &&& X & \mt{variable} \\ - &&& M.X & \mt{projection} \\ - &&& M(M) & \mt{functor application} \\ - &&& \mt{functor}(X : S) : S = M & \mt{functor abstraction} \\ + \textrm{Modules} & M &::=& \mt{struct} \; d^* \; \mt{end} & \textrm{constant} \\ + &&& X & \textrm{variable} \\ + &&& M.X & \textrm{projection} \\ + &&& M(M) & \textrm{functor application} \\ + &&& \mt{functor}(X : S) : S = M & \textrm{functor abstraction} \\ \end{array}$$ There are two kinds of Ur files. A file named $M\texttt{.ur}$ is an \emph{implementation file}, and it should contain a sequence of declarations $d^*$. A file named $M\texttt{.urs}$ is an \emph{interface file}; it must always have a matching $M\texttt{.ur}$ and should contain a sequence of signature items $s^*$. When both files are present, the overall effect is the same as a monolithic declaration $\mt{structure} \; M : \mt{sig} \; s^* \; \mt{end} = \mt{struct} \; d^* \; \mt{end}$. When no interface file is included, the overall effect is similar, with a signature for module $M$ being inferred rather than just checked against an interface. +\subsection{Shorthands} + +There are a variety of derived syntactic forms that elaborate into the core syntax from the last subsection. We will present the additional forms roughly following the order in which we presented the constructs that they elaborate into. + +In many contexts where record fields are expected, like in a projection $e.c$, a constant field may be written as simply $X$, rather than $\#X$. + +A record type may be written $\{(c = c,)^*\}$, which elaborates to $\$[(c = c,)^*]$. + +A tuple type $(\tau_1, \ldots, \tau_n)$ expands to a record type $\{1 = \tau_1, \ldots, n = \tau_n\}$, with natural numbers as field names. A tuple pattern $(p_1, \ldots, p_n)$ expands to a rigid record pattern $\{1 = p_1, \ldots, n = p_n\}$. Positive natural numbers may be used in most places where field names would be allowed. + +In general, several adjacent $\lambda$ forms may be combined into one, and kind and type annotations may be omitted, in which case they are implicitly included as wildcards. More formally, for constructor-level abstractions, we can define a new non-terminal $b ::= x \mid (x :: \kappa) \mid [c \sim c]$ and allow composite abstractions of the form $\lambda b^+ \Rightarrow c$, elaborating into the obvious sequence of one core $\lambda$ per element of $b^+$. + +For any signature item or declaration that defines some entity to be equal to $A$ with classification annotation $B$ (e.g., $\mt{val} \; x : B = A$), $B$ and the preceding colon (or similar punctuation) may be omitted, in which case it is filled in as a wildcard. + +A signature item or declaration $\mt{type} \; x$ or $\mt{type} \; x = \tau$ is elaborated into $\mt{con} \; x :: \mt{Type}$ or $\mt{con} \; x :: \mt{Type} = \tau$, respectively. + +A signature item or declaration $\mt{class} \; x = \lambda y :: \mt{Type} \Rightarrow c$ may be abbreviated $\mt{class} \; x \; y = c$. + +Handling of implicit and explicit constructor arguments may be tweaked with some prefixes to variable references. An expression $@x$ is a version of $x$ where all implicit constructor arguments have been made explicit. An expression $@@x$ achieves the same effect, additionally halting automatic resolution of type class instances. The same syntax works for variables projected out of modules and for capitalized variables (datatype constructors). + +At the expression level, an analogue is available of the composite $\lambda$ form for constructors. We define the language of binders as $b ::= x \mid (x : \tau) \mid (x \; ? \; \kappa) \mid [c \sim c]$. A lone variable $x$ as a binder stands for an expression variable of unspecified type. + +A $\mt{val}$ or $\mt{val} \; \mt{rec}$ declaration may include expression binders before the equal sign, following the binder grammar from the last paragraph. Such declarations are elaborated into versions that add additional $\lambda$s to the fronts of the righthand sides, as appropriate. The keyword $\mt{fun}$ is a synonym for $\mt{val} \; \mt{rec}$. + +A signature item $\mt{functor} \; X_1 \; (X_2 : S_1) : S_2$ is elaborated into $\mt{structure} \; X_1 : \mt{functor}(X_2 : S_1) : S_2$. A declaration $\mt{functor} \; X_1 \; (X_2 : S_1) : S_2 = M$ is elaborated into $\mt{structure} \; X_1 : \mt{functor}(X_2 : S_1) : S_2 = \mt{functor}(X_2 : S_1) : S_2 = M$. + +A declaration $\mt{table} \; x : \{(c = c,)^*\}$ is elaborated into $\mt{table} \; x : [(c = c,)^*]$ + +The syntax $\mt{where} \; \mt{type}$ is an alternate form of $\mt{where} \; \mt{con}$. + +The syntax $\mt{if} \; e \; \mt{then} \; e_1 \; \mt{else} \; e_2$ expands to $\mt{case} \; e \; \mt{of} \; \mt{Basis}.\mt{True} \Rightarrow e_1 \mid \mt{Basis}.\mt{False} \Rightarrow e_2$. + +There are infix operator syntaxes for a number of functions defined in the $\mt{Basis}$ module. There is $=$ for $\mt{eq}$, $\neq$ for $\mt{neq}$, $-$ for $\mt{neg}$ (as a prefix operator) and $\mt{minus}$, $+$ for $\mt{plus}$, $\times$ for $\mt{times}$, $/$ for $\mt{div}$, $\%$ for $\mt{mod}$, $<$ for $\mt{lt}$, $\leq$ for $\mt{le}$, $>$ for $\mt{gt}$, and $\geq$ for $\mt{ge}$. + +A signature item $\mt{table} \; x : c$ is shorthand for $\mt{val} \; x : \mt{Basis}.\mt{sql\_table} \; c$. $\mt{sequence} \; x$ is short for $\mt{val} \; x : \mt{Basis}.\mt{sql\_sequence}$, and $\mt{cookie} \; x : \tau$ is shorthand for $\mt{val} \; x : \mt{Basis}.\mt{http\_cookie} \; \tau$. + \end{document} \ No newline at end of file -- cgit v1.2.3 From 413a2ddcfcbf235bf0cdd220f7ecefe93db37bf0 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 29 Nov 2008 09:34:11 -0500 Subject: Kinding --- doc/manual.tex | 95 ++++++++++++++++++++++++++++++++++++++++++++++++++++++---- 1 file changed, 90 insertions(+), 5 deletions(-) diff --git a/doc/manual.tex b/doc/manual.tex index 9a2f4173..0bd129cd 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -68,14 +68,14 @@ $$\begin{array}{rrcll} \emph{Constructors} are the main class of compile-time-only data. They include proper types and are classified by kinds. $$\begin{array}{rrcll} \textrm{Constructors} & c, \tau &::=& (c) :: \kappa & \textrm{kind annotation} \\ - &&& x & \textrm{constructor variable} \\ + &&& \hat{x} & \textrm{constructor variable} \\ \\ &&& \tau \to \tau & \textrm{function type} \\ &&& x \; ? \; \kappa \to \tau & \textrm{polymorphic function type} \\ &&& \$ c & \textrm{record type} \\ \\ &&& c \; c & \textrm{type-level function application} \\ - &&& \lambda x \; ? \; \kappa \Rightarrow c & \textrm{type-level function abstraction} \\ + &&& \lambda x \; :: \; \kappa \Rightarrow c & \textrm{type-level function abstraction} \\ \\ &&& () & \textrm{type-level unit} \\ &&& \#X & \textrm{field name} \\ @@ -91,6 +91,9 @@ $$\begin{array}{rrcll} \\ &&& \_ :: \kappa & \textrm{wildcard} \\ &&& (c) & \textrm{explicit precedence} \\ + \\ + \textrm{Qualified uncapitalized variables} & \hat{x} &::=& x & \textrm{not from a module} \\ + &&& M.x & \textrm{projection from a module} \\ \end{array}$$ Modules of the module system are described by \emph{signatures}. @@ -162,9 +165,6 @@ $$\begin{array}{rrcll} \\ \textrm{Local declarations} & ed &::=& \cd{val} \; x : \tau = e & \textrm{non-recursive value} \\ &&& \cd{val} \; \cd{rec} \; (x : \tau = e \; \cd{and})^+ & \textrm{mutually-recursive values} \\ - \\ - \textrm{Qualified uncapitalized variables} & \hat{x} &::=& x & \textrm{not from a module} \\ - &&& M.x & \textrm{projection from a module} \\ \end{array}$$ \emph{Declarations} primarily bring new symbols into context. @@ -229,4 +229,89 @@ There are infix operator syntaxes for a number of functions defined in the $\mt{ A signature item $\mt{table} \; x : c$ is shorthand for $\mt{val} \; x : \mt{Basis}.\mt{sql\_table} \; c$. $\mt{sequence} \; x$ is short for $\mt{val} \; x : \mt{Basis}.\mt{sql\_sequence}$, and $\mt{cookie} \; x : \tau$ is shorthand for $\mt{val} \; x : \mt{Basis}.\mt{http\_cookie} \; \tau$. + +\section{Static Semantics} + +In this section, we give a declarative presentation of Ur's typing rules and related judgments. Inference is the subject of the next section; here, we assume that an oracle has filled in all wildcards with concrete values. + +Since there is significant mutual recursion among the judgments, we introduce them all before beginning to give rules. We use the same variety of contexts throughout this section, implicitly introducing new sorts of context entries as needed. +\begin{itemize} +\item $\Gamma \vdash c :: \kappa$ assigns a kind to a constructor in a context. +\item $\Gamma \vdash c \sim c$ proves the disjointness of two record constructors; that is, that they share no field names. We overload the judgment to apply to pairs of field names as well. +\item $\Gamma \vdash c \hookrightarrow \overline{c}$ proves that record constructor $c$ decomposes into set $\overline{c}$ of field names and record constructors. +\item $\Gamma \vdash c \equiv c$ proves the computational equivalence of two constructors. This is often called a \emph{definitional equality} in the world of type theory. +\item $\Gamma \vdash e : \tau$ is a standard typing judgment. +\item $\Gamma \vdash M : S$ is the module signature checking judgment. +\item $\mt{proj}(M, S, V)$ is a partial function for projecting a signature item from a signature $S$, given the module $M$ that we project from. $V$ may be $\mt{con} \; x$, $\mt{val} \; x$, $\mt{signature} \; X$, or $\mt{structure} \; X$. The parameter $M$ is needed because the projected signature item may refer to other items of $S$. +\end{itemize} + +\subsection{Kinding} + +$$\infer{\Gamma \vdash (c) :: \kappa :: \kappa}{ + \Gamma \vdash c :: \kappa +} +\quad \infer{\Gamma \vdash x :: \kappa}{ + x :: \kappa \in \Gamma +} +\quad \infer{\Gamma \vdash x :: \kappa}{ + x :: \kappa = c \in \Gamma +}$$ + +$$\infer{\Gamma \vdash M.x :: \kappa}{ + \Gamma \vdash M : S + & \mt{proj}(M, S, \mt{con} \; x) = \kappa +} +\quad \infer{\Gamma \vdash M.x :: \kappa}{ + \Gamma \vdash M : S + & \mt{proj}(M, S, \mt{con} \; x) = (\kappa, c) +}$$ + +$$\infer{\Gamma \vdash \tau_1 \to \tau_2 :: \mt{Type}}{ + \Gamma \vdash \tau_1 :: \mt{Type} + & \Gamma \vdash \tau_2 :: \mt{Type} +} +\quad \infer{\Gamma \vdash x \; ? \: \kappa \to \tau :: \mt{Type}}{ + \Gamma, x :: \kappa \vdash \tau :: \mt{Type} +} +\quad \infer{\Gamma \vdash \$c :: \mt{Type}}{ + \Gamma \vdash c :: \{\mt{Type}\} +}$$ + +$$\infer{\Gamma \vdash c_1 \; c_2 :: \kappa_2}{ + \Gamma \vdash c_1 :: \kappa_1 \to \kappa_2 + & \Gamma \vdash c_2 :: \kappa_1 +} +\quad \infer{\Gamma \vdash \lambda x \; :: \; \kappa_1 \Rightarrow c :: \kappa_1 \to \kappa_2}{ + \Gamma, x :: \kappa_1 \vdash c :: \kappa_2 +}$$ + +$$\infer{\Gamma \vdash () :: \mt{Unit}}{} +\quad \infer{\Gamma \vdash \#X :: \mt{Name}}{}$$ + +$$\infer{\Gamma \vdash [\overline{c_i = c'_i}] :: \{\kappa\}}{ + \forall i: \Gamma \vdash c_i : \mt{Name} + & \Gamma \vdash c'_i :: \kappa + & \forall i \neq j: \Gamma \vdash c_i \sim c_j +} +\quad \infer{\Gamma \vdash c_1 \rc c_2 :: \{\kappa\}}{ + \Gamma \vdash c_1 :: \{\kappa\} + & \Gamma \vdash c_2 :: \{\kappa\} + & \Gamma \vdash c_1 \sim c_2 +}$$ + +$$\infer{\Gamma \vdash \mt{fold} :: ((\mt{Name} \to \kappa_1 \to \kappa_2 \to \kappa_2) \to \kappa_2 \to \{\kappa_1\} \to \kappa_2}{}$$ + +$$\infer{\Gamma \vdash (\overline c) :: (k_1 \times \ldots \times k_n)}{ + \forall i: \Gamma \vdash c_i :: k_i +} +\quad \infer{\Gamma \vdash c.i :: k_i}{ + \Gamma \vdash c :: (k_1 \times \ldots \times k_n) +}$$ + +$$\infer{\Gamma \vdash \lambda [c_1 \sim c_2] \Rightarrow c :: \kappa}{ + \Gamma \vdash c_1 :: \{\kappa'\} + & \Gamma \vdash c_2 :: \{\kappa'\} + & \Gamma, c_1 \sim c_2 \vdash c :: \kappa +}$$ + \end{document} \ No newline at end of file -- cgit v1.2.3 From 96c1d0efd00362926493295a132c19a209ac7838 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 29 Nov 2008 09:48:10 -0500 Subject: Disjointness --- doc/manual.tex | 38 +++++++++++++++++++++++++++++++++++++- 1 file changed, 37 insertions(+), 1 deletion(-) diff --git a/doc/manual.tex b/doc/manual.tex index 0bd129cd..2b0f2c57 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -238,7 +238,7 @@ Since there is significant mutual recursion among the judgments, we introduce th \begin{itemize} \item $\Gamma \vdash c :: \kappa$ assigns a kind to a constructor in a context. \item $\Gamma \vdash c \sim c$ proves the disjointness of two record constructors; that is, that they share no field names. We overload the judgment to apply to pairs of field names as well. -\item $\Gamma \vdash c \hookrightarrow \overline{c}$ proves that record constructor $c$ decomposes into set $\overline{c}$ of field names and record constructors. +\item $\Gamma \vdash c \hookrightarrow C$ proves that record constructor $c$ decomposes into set $C$ of field names and record constructors. \item $\Gamma \vdash c \equiv c$ proves the computational equivalence of two constructors. This is often called a \emph{definitional equality} in the world of type theory. \item $\Gamma \vdash e : \tau$ is a standard typing judgment. \item $\Gamma \vdash M : S$ is the module signature checking judgment. @@ -314,4 +314,40 @@ $$\infer{\Gamma \vdash \lambda [c_1 \sim c_2] \Rightarrow c :: \kappa}{ & \Gamma, c_1 \sim c_2 \vdash c :: \kappa }$$ +\subsection{Record Disjointness} + +We will use a keyword $\mt{map}$ as a shorthand, such that, for $f$ of kind $\kappa \to \kappa'$, $\mt{map} \; f$ stands for $\mt{fold} \; (\lambda (x_1 :: \mt{Name}) (x_2 :: \kappa) (x_3 :: \{\kappa'\}) \Rightarrow [x_1 = f \; x_2] \rc x_3) \; []$. + +$$\infer{\Gamma \vdash c_1 \sim c_2}{ + \Gamma \vdash c_1 \hookrightarrow c'_1 + & \Gamma \vdash c_2 \hookrightarrow c'_2 + & \forall c''_1 \in c'_1, c''_2 \in c'_2: \Gamma \vdash c''_1 \sim c''_2 +} +\quad \infer{\Gamma \vdash X \sim X'}{ + X \neq X' +}$$ + +$$\infer{\Gamma \vdash c_1 \sim c_2}{ + c'_1 \sim c'_2 \in \Gamma + & \Gamma \vdash c'_1 \hookrightarrow c''_1 + & \Gamma \vdash c'_2 \hookrightarrow c''_2 + & c_1 \in c''_1 + & c_2 \in c''_2 +}$$ + +$$\infer{\Gamma \vdash c \hookrightarrow \{c\}}{} +\quad \infer{\Gamma \vdash [\overline{c = c'}] \hookrightarrow \{\overline{c}\}}{} +\quad \infer{\Gamma \vdash c_1 \rc c_2 \hookrightarrow C_1 \cup C_2}{ + \Gamma \vdash c_1 \hookrightarrow C_1 + & \Gamma \vdash c_2 \hookrightarrow C_2 +} +\quad \infer{\Gamma \vdash c \hookrightarrow C}{ + \Gamma \vdash c \equiv c' + & \Gamma \vdash c' \hookrightarrow C +} +\quad \infer{\Gamma \vdash \mt{map} \; f \; c \hookrightarrow C}{ + \Gamma \vdash c \hookrightarrow C +}$$ + + \end{document} \ No newline at end of file -- cgit v1.2.3 From e4fff6ca5e4e4d1e6a4dba3456a002e4f6bc3e2d Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 29 Nov 2008 10:05:46 -0500 Subject: Definitional equality --- doc/manual.tex | 43 +++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 43 insertions(+) diff --git a/doc/manual.tex b/doc/manual.tex index 2b0f2c57..cff270df 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -349,5 +349,48 @@ $$\infer{\Gamma \vdash c \hookrightarrow \{c\}}{} \Gamma \vdash c \hookrightarrow C }$$ +\subsection{Definitional Equality} + +We use $\mathcal C$ to stand for a one-hole context that, when filled, yields a constructor. The notation $\mathcal C[c]$ plugs $c$ into $\mathcal C$. We omit the standard definition of one-hole contexts. We write $[x \mapsto c_1]c_2$ for capture-avoiding substitution of $c_1$ for $x$ in $c_2$. + +$$\infer{\Gamma \vdash c \equiv c}{} +\quad \infer{\Gamma \vdash c_1 \equiv c_2}{ + \Gamma \vdash c_2 \equiv c_1 +} +\quad \infer{\Gamma \vdash c_1 \equiv c_3}{ + \Gamma \vdash c_1 \equiv c_2 + & \Gamma \vdash c_2 \equiv c_3 +} +\quad \infer{\Gamma \vdash \mathcal C[c_1] \equiv \mathcal C[c_2]}{ + \Gamma \vdash c_1 \equiv c_2 +}$$ + +$$\infer{\Gamma \vdash x \equiv c}{ + x :: \kappa = c \in \Gamma +} +\quad \infer{\Gamma \vdash M.x \equiv c}{ + \Gamma \vdash M : S + & \mt{proj}(M, S, \mt{con} \; x) = (\kappa, c) +} +\quad \infer{\Gamma \vdash (\overline c).i \equiv c_i}{}$$ + +$$\infer{\Gamma \vdash (\lambda x :: \kappa \Rightarrow c) \; c' \equiv [x \mapsto c'] c}{} +\quad \infer{\Gamma \vdash c_1 \rc c_2 \equiv c_2 \rc c_1}{} +\quad \infer{\Gamma \vdash c_1 \rc (c_2 \rc c_3) \equiv (c_1 \rc c_2) \rc c_3}{}$$ + +$$\infer{\Gamma \vdash [] \rc c \equiv c}{} +\quad \infer{\Gamma \vdash [\overline{c_1 = c'_1}] \rc [\overline{c_2 = c'_2}] \equiv [\overline{c_1 = c'_1}, \overline{c_2 = c'_2}]}{}$$ + +$$\infer{\Gamma \vdash \lambda [c_1 \sim c_2] \Rightarrow c \equiv c}{ + \Gamma \vdash c_1 \sim c_2 +} +\quad \infer{\Gamma \vdash \mt{fold} \; f \; i \; [] \equiv i}{} +\quad \infer{\Gamma \vdash \mt{fold} \; f \; i \; ([c_1 = c_2] \rc c) \equiv f \; c_1 \; c_2 \; (\mt{fold} \; f \; i \; c)}{}$$ + +$$\infer{\Gamma \vdash \mt{map} \; (\lambda x \Rightarrow x) \; c \equiv c}{} +\quad \infer{\Gamma \vdash \mt{fold} \; f \; i \; (\mt{map} \; f' \; c) + \equiv \mt{fold} \; (\lambda (x_1 :: \mt{Name}) (x_2 :: \kappa) \Rightarrow f \; x_1 \; (f' \; x_2)) \; i \; c}{}$$ + +$$\infer{\Gamma \vdash \mt{map} \; f \; (c_1 \rc c_2) \equiv \mt{map} \; f \; c_1 \rc \mt{map} \; f \; c_2}{}$$ \end{document} \ No newline at end of file -- cgit v1.2.3 From 6748925a8c158e84a40b2e8f0142eaea7691d2f6 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 29 Nov 2008 10:34:56 -0500 Subject: Typing --- doc/manual.tex | 92 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 92 insertions(+) diff --git a/doc/manual.tex b/doc/manual.tex index cff270df..dec14cd2 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -201,6 +201,8 @@ In many contexts where record fields are expected, like in a projection $e.c$, a A record type may be written $\{(c = c,)^*\}$, which elaborates to $\$[(c = c,)^*]$. +The notation $[c_1, \ldots, c_n]$ is shorthand for $[c_1 = (), \ldots, c_n = ()]$. + A tuple type $(\tau_1, \ldots, \tau_n)$ expands to a record type $\{1 = \tau_1, \ldots, n = \tau_n\}$, with natural numbers as field names. A tuple pattern $(p_1, \ldots, p_n)$ expands to a rigid record pattern $\{1 = p_1, \ldots, n = p_n\}$. Positive natural numbers may be used in most places where field names would be allowed. In general, several adjacent $\lambda$ forms may be combined into one, and kind and type annotations may be omitted, in which case they are implicitly included as wildcards. More formally, for constructor-level abstractions, we can define a new non-terminal $b ::= x \mid (x :: \kappa) \mid [c \sim c]$ and allow composite abstractions of the form $\lambda b^+ \Rightarrow c$, elaborating into the obvious sequence of one core $\lambda$ per element of $b^+$. @@ -241,6 +243,8 @@ Since there is significant mutual recursion among the judgments, we introduce th \item $\Gamma \vdash c \hookrightarrow C$ proves that record constructor $c$ decomposes into set $C$ of field names and record constructors. \item $\Gamma \vdash c \equiv c$ proves the computational equivalence of two constructors. This is often called a \emph{definitional equality} in the world of type theory. \item $\Gamma \vdash e : \tau$ is a standard typing judgment. +\item $\Gamma \vdash p \leadsto \Gamma, \tau$ combines typing of patterns with calculation of which new variables they bind. +\item $\Gamma \vdash d \leadsto \Gamma$ expresses how a declaration modifies a context. We overload this judgment to apply to sequences of declarations. \item $\Gamma \vdash M : S$ is the module signature checking judgment. \item $\mt{proj}(M, S, V)$ is a partial function for projecting a signature item from a signature $S$, given the module $M$ that we project from. $V$ may be $\mt{con} \; x$, $\mt{val} \; x$, $\mt{signature} \; X$, or $\mt{structure} \; X$. The parameter $M$ is needed because the projected signature item may refer to other items of $S$. \end{itemize} @@ -393,4 +397,92 @@ $$\infer{\Gamma \vdash \mt{map} \; (\lambda x \Rightarrow x) \; c \equiv c}{} $$\infer{\Gamma \vdash \mt{map} \; f \; (c_1 \rc c_2) \equiv \mt{map} \; f \; c_1 \rc \mt{map} \; f \; c_2}{}$$ +\subsection{Typing} + +We assume the existence of a function $T$ assigning types to literal constants. It maps integer constants to $\mt{Basis}.\mt{int}$, float constants to $\mt{Basis}.\mt{float}$, and string constants to $\mt{Basis}.\mt{string}$. + +We also refer to a function $\mathcal I$, such that $\mathcal I(\tau)$ ``uses an oracle'' to instantiate all constructor function arguments at the beginning of $\tau$ that are marked implicit; i.e., replace $x_1 ::: \kappa_1 \to \ldots \to x_n ::: \kappa_n \to \tau$ with $[x_1 \mapsto c_1]\ldots[x_n \mapsto c_n]\tau$, where the $c_i$s are inferred and $\tau$ does not start like $x ::: \kappa \to \tau'$. + +$$\infer{\Gamma \vdash e : \tau : \tau}{ + \Gamma \vdash e : \tau +} +\quad \infer{\Gamma \vdash e : \tau}{ + \Gamma \vdash e : \tau' + & \Gamma \vdash \tau' \equiv \tau +} +\quad \infer{\Gamma \vdash \ell : T(\ell)}{}$$ + +$$\infer{\Gamma \vdash x : \mathcal I(\tau)}{ + x : \tau \in \Gamma +} +\quad \infer{\Gamma \vdash M.x : \mathcal I(\tau)}{ + \Gamma \vdash M : S + & \mt{proj}(M, S, \mt{val} \; x) = \tau +} +\quad \infer{\Gamma \vdash X : \mathcal I(\tau)}{ + X : \tau \in \Gamma +} +\quad \infer{\Gamma \vdash M.X : \mathcal I(\tau)}{ + \Gamma \vdash M : S + & \mt{proj}(M, S, \mt{val} \; X) = \tau +}$$ + +$$\infer{\Gamma \vdash e_1 \; e_2 : \tau_2}{ + \Gamma \vdash e_1 : \tau_1 \to \tau_2 + & \Gamma \vdash e_2 : \tau_1 +} +\quad \infer{\Gamma \vdash \lambda x : \tau_1 \Rightarrow e : \tau_1 \to \tau_2}{ + \Gamma, x : \tau_1 \vdash e : \tau_2 +}$$ + +$$\infer{\Gamma \vdash e [c] : [x \mapsto c]\tau}{ + \Gamma \vdash e : x :: \kappa \to \tau + & \Gamma \vdash c :: \kappa +} +\quad \infer{\Gamma \vdash \lambda x \; ? \; \kappa \Rightarrow e : x \; ? \; \kappa \to \tau}{ + \Gamma, x :: \kappa \vdash e : \tau +}$$ + +$$\infer{\Gamma \vdash \{\overline{c = e}\} : \{\overline{c : \tau}\}}{ + \forall i: \Gamma \vdash c_i :: \mt{Name} + & \Gamma \vdash e_i : \tau_i + & \forall i \neq j: \Gamma \vdash c_i \sim c_j +} +\quad \infer{\Gamma \vdash e.c : \tau}{ + \Gamma \vdash e : \$([c = \tau] \rc c') +} +\quad \infer{\Gamma \vdash e_1 \rc e_2 : \$(c_1 \rc c_2)}{ + \Gamma \vdash e_1 : \$c_1 + & \Gamma \vdash e_2 : \$c_2 +}$$ + +$$\infer{\Gamma \vdash e \rcut c : \$c'}{ + \Gamma \vdash e : \$([c = \tau] \rc c') +} +\quad \infer{\Gamma \vdash e \rcutM c : \$c'}{ + \Gamma \vdash e : \$(c \rc c') +}$$ + +$$\infer{\Gamma \vdash \mt{fold} : \begin{array}{c} + x_1 :: (\{\kappa\} \to \tau) + \to (x_2 :: \mt{Name} \to x_3 :: \kappa \to x_4 :: \{\kappa\} \to \lambda [[x_2] \sim x_4] + \Rightarrow x_1 \; x_4 \to x_1 \; ([x_2 = x_3] \rc x_4)) \\ + \to x_1 \; [] \to x_5 :: \{\kappa\} \to x_1 \; x_5 + \end{array}}{}$$ + +$$\infer{\Gamma \vdash \mt{let} \; \overline{ed} \; \mt{in} \; e \; \mt{end} : \tau}{ + \Gamma \vdash \overline{ed} \leadsto \Gamma' + & \Gamma' \vdash e : \tau +} +\quad \infer{\Gamma \vdash \mt{case} \; e \; \mt{of} \; \overline{p \Rightarrow e} : \tau}{ + \forall i: \Gamma \vdash p_i \leadsto \Gamma_i, \tau' + & \Gamma_i \vdash e_i : \tau +}$$ + +$$\infer{\Gamma \vdash [c_1 \sim c_2] \Rightarrow e : [c_1 \sim c_2] \Rightarrow \tau}{ + \Gamma \vdash c_1 :: \{\kappa\} + & \Gamma \vdash c_2 :: \{\kappa\} + & \Gamma, c_1 \sim c_2 \vdash e : \tau +}$$ + \end{document} \ No newline at end of file -- cgit v1.2.3 From 73de524554aaa11c454e95cec39e8ada98c44cf4 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 29 Nov 2008 10:49:47 -0500 Subject: Pattern typing --- doc/manual.tex | 40 ++++++++++++++++++++++++++++++++++++++-- 1 file changed, 38 insertions(+), 2 deletions(-) diff --git a/doc/manual.tex b/doc/manual.tex index dec14cd2..db679405 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -243,7 +243,7 @@ Since there is significant mutual recursion among the judgments, we introduce th \item $\Gamma \vdash c \hookrightarrow C$ proves that record constructor $c$ decomposes into set $C$ of field names and record constructors. \item $\Gamma \vdash c \equiv c$ proves the computational equivalence of two constructors. This is often called a \emph{definitional equality} in the world of type theory. \item $\Gamma \vdash e : \tau$ is a standard typing judgment. -\item $\Gamma \vdash p \leadsto \Gamma, \tau$ combines typing of patterns with calculation of which new variables they bind. +\item $\Gamma \vdash p \leadsto \Gamma; \tau$ combines typing of patterns with calculation of which new variables they bind. \item $\Gamma \vdash d \leadsto \Gamma$ expresses how a declaration modifies a context. We overload this judgment to apply to sequences of declarations. \item $\Gamma \vdash M : S$ is the module signature checking judgment. \item $\mt{proj}(M, S, V)$ is a partial function for projecting a signature item from a signature $S$, given the module $M$ that we project from. $V$ may be $\mt{con} \; x$, $\mt{val} \; x$, $\mt{signature} \; X$, or $\mt{structure} \; X$. The parameter $M$ is needed because the projected signature item may refer to other items of $S$. @@ -397,7 +397,7 @@ $$\infer{\Gamma \vdash \mt{map} \; (\lambda x \Rightarrow x) \; c \equiv c}{} $$\infer{\Gamma \vdash \mt{map} \; f \; (c_1 \rc c_2) \equiv \mt{map} \; f \; c_1 \rc \mt{map} \; f \; c_2}{}$$ -\subsection{Typing} +\subsection{Expression Typing} We assume the existence of a function $T$ assigning types to literal constants. It maps integer constants to $\mt{Basis}.\mt{int}$, float constants to $\mt{Basis}.\mt{float}$, and string constants to $\mt{Basis}.\mt{string}$. @@ -485,4 +485,40 @@ $$\infer{\Gamma \vdash [c_1 \sim c_2] \Rightarrow e : [c_1 \sim c_2] \Rightarrow & \Gamma, c_1 \sim c_2 \vdash e : \tau }$$ +\subsection{Pattern Typing} + +$$\infer{\Gamma \vdash \_ \leadsto \Gamma; \tau}{} +\quad \infer{\Gamma \vdash x \leadsto \Gamma, x : \tau; \tau}{} +\quad \infer{\Gamma \vdash \ell \leadsto \Gamma; T(\ell)}{}$$ + +$$\infer{\Gamma \vdash X \leadsto \Gamma; \overline{[x_i \mapsto \tau'_i]}\tau}{ + X : \overline{x ::: \mt{Type}} \to \tau \in \Gamma + & \textrm{$\tau$ not a function type} +} +\quad \infer{\Gamma \vdash X \; p \leadsto \Gamma'; \overline{[x_i \mapsto \tau'_i]}\tau}{ + X : \overline{x ::: \mt{Type}} \to \tau'' \to \tau \in \Gamma + & \Gamma \vdash p \leadsto \Gamma'; \overline{[x_i \mapsto \tau'_i]}\tau'' +}$$ + +$$\infer{\Gamma \vdash M.X \leadsto \Gamma; \overline{[x_i \mapsto \tau'_i]}\tau}{ + \Gamma \vdash M : S + & \mt{proj}(M, S, \mt{val} \; X) = \overline{x ::: \mt{Type}} \to \tau + & \textrm{$\tau$ not a function type} +}$$ + +$$\infer{\Gamma \vdash M.X \; p \leadsto \Gamma'; \overline{[x_i \mapsto \tau'_i]}\tau}{ + \Gamma \vdash M : S + & \mt{proj}(M, S, \mt{val} \; X) = \overline{x ::: \mt{Type}} \to \tau'' \to \tau + & \Gamma \vdash p \leadsto \Gamma'; \overline{[x_i \mapsto \tau'_i]}\tau'' +}$$ + +$$\infer{\Gamma \vdash \{\overline{x = p}\} \leadsto \Gamma_n; \{\overline{x = \tau}\}}{ + \Gamma_0 = \Gamma + & \forall i: \Gamma_i \vdash p_i \leadsto \Gamma_{i+1}; \tau_i +} +\quad \infer{\Gamma \vdash \{\overline{x = p}, \ldots\} \leadsto \Gamma_n; \$([\overline{x = \tau}] \rc c)}{ + \Gamma_0 = \Gamma + & \forall i: \Gamma_i \vdash p_i \leadsto \Gamma_{i+1}; \tau_i +}$$ + \end{document} \ No newline at end of file -- cgit v1.2.3 From e2c7097ddf12808ae9f108e911e93ab99e640d80 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 29 Nov 2008 11:33:51 -0500 Subject: Declaration typing --- doc/manual.tex | 83 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 81 insertions(+), 2 deletions(-) diff --git a/doc/manual.tex b/doc/manual.tex index db679405..4df95230 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -181,8 +181,8 @@ $$\begin{array}{rrcll} &&& \mt{open} \; \mt{constraints} \; M & \textrm{inclusion of just the constraints from a module} \\ &&& \mt{table} \; x : c & \textrm{SQL table} \\ &&& \mt{sequence} \; x & \textrm{SQL sequence} \\ - &&& \mt{class} \; x = c & \textrm{concrete type class} \\ &&& \mt{cookie} \; x : \tau & \textrm{HTTP cookie} \\ + &&& \mt{class} \; x = c & \textrm{concrete type class} \\ \\ \textrm{Modules} & M &::=& \mt{struct} \; d^* \; \mt{end} & \textrm{constant} \\ &&& X & \textrm{variable} \\ @@ -245,8 +245,10 @@ Since there is significant mutual recursion among the judgments, we introduce th \item $\Gamma \vdash e : \tau$ is a standard typing judgment. \item $\Gamma \vdash p \leadsto \Gamma; \tau$ combines typing of patterns with calculation of which new variables they bind. \item $\Gamma \vdash d \leadsto \Gamma$ expresses how a declaration modifies a context. We overload this judgment to apply to sequences of declarations. +\item $\Gamma \vdash S$ is the signature validity judgment. +\item $\Gamma \vdash S \leq S$ is the signature compatibility judgment. \item $\Gamma \vdash M : S$ is the module signature checking judgment. -\item $\mt{proj}(M, S, V)$ is a partial function for projecting a signature item from a signature $S$, given the module $M$ that we project from. $V$ may be $\mt{con} \; x$, $\mt{val} \; x$, $\mt{signature} \; X$, or $\mt{structure} \; X$. The parameter $M$ is needed because the projected signature item may refer to other items of $S$. +\item $\mt{proj}(M, S, V)$ is a partial function for projecting a signature item from a signature $S$, given the module $M$ that we project from. $V$ may be $\mt{con} \; x$, $\mt{datatype} \; x$, $\mt{val} \; x$, $\mt{signature} \; X$, or $\mt{structure} \; X$. The parameter $M$ is needed because the projected signature item may refer to other items of $S$. \end{itemize} \subsection{Kinding} @@ -521,4 +523,81 @@ $$\infer{\Gamma \vdash \{\overline{x = p}\} \leadsto \Gamma_n; \{\overline{x = \ & \forall i: \Gamma_i \vdash p_i \leadsto \Gamma_{i+1}; \tau_i }$$ +\subsection{Declaration Typing} + +We use an auxiliary judgment $\overline{y}; x; \Gamma \vdash \overline{dc} \leadsto \Gamma'$, expressing the enrichment of $\Gamma$ with the types of the datatype constructors $\overline{dc}$, when they are known to belong to datatype $x$ with type parameters $\overline{y}$. + +This is the first judgment where we deal with type classes, for the $\mt{class}$ declaration form. We will omit their special handling in this formal specification. In the compiler, a set of available type classes and their instances is maintained, and these instances are used to fill in expression wildcards. + +We presuppose the existence of a function $\mathcal O$, where $\mathcal(M, S)$ implements the $\mt{open}$ declaration by producing a context with the appropriate entry for each available component of module $M$ with signature $S$. Where possible, $\mathcal O$ uses ``transparent'' entries (e.g., an abstract type $M.x$ is mapped to $x :: \mt{Type} = M.x$), so that the relationship with $M$ is maintained. A related function $\mathcal O_c$ builds a context containing the disjointness constraints found in $S$. + +$$\infer{\Gamma \vdash \cdot \leadsto \Gamma}{} +\quad \infer{\Gamma \vdash d, \overline{d} \leadsto \Gamma''}{ + \Gamma \vdash d \leadsto \Gamma' + & \Gamma' \vdash \overline{d} \leadsto \Gamma'' +}$$ + +$$\infer{\Gamma \vdash \mt{con} \; x :: \kappa = c \leadsto \Gamma, x :: \kappa = c}{ + \Gamma \vdash c :: \kappa +} +\quad \infer{\Gamma \vdash \mt{datatype} \; x \; \overline{y} = \overline{dc} \leadsto \Gamma'}{ + \overline{y}; x; \Gamma, x :: \mt{Type}^{\mt{len}(\overline y)} \to \mt{Type} \vdash \overline{dc} \leadsto \Gamma' +}$$ + +$$\infer{\Gamma \vdash \mt{datatype} \; x = \mt{datatype} \; M.z \leadsto \Gamma'}{ + \Gamma \vdash M : S + & \mt{proj}(M, S, \mt{datatype} \; z) = (\overline{y}, \overline{dc}) + & \overline{y}; x; \Gamma, x :: \mt{Type}^{\mt{len}(\overline y)} \to \mt{Type} = M.z \vdash \overline{dc} \leadsto \Gamma' +}$$ + +$$\infer{\Gamma \vdash \mt{val} \; x : \tau = e \leadsto \Gamma, x : \tau}{ + \Gamma \vdash e : \tau +}$$ + +$$\infer{\Gamma \vdash \mt{val} \; \mt{rec} \; \overline{x : \tau = e} \leadsto \Gamma, \overline{x : \tau}}{ + \forall i: \Gamma, \overline{x : \tau} \vdash e_i : \tau_i + & \textrm{$e_i$ starts with an expression $\lambda$, optionally preceded by constructor and disjointness $\lambda$s} +}$$ + +$$\infer{\Gamma \vdash \mt{structure} \; X : S = M \leadsto \Gamma, X : S}{ + \Gamma \vdash M : S +} +\quad \infer{\Gamma \vdash \mt{siganture} \; X = S \leadsto \Gamma, X = S}{ + \Gamma \vdash S +}$$ + +$$\infer{\Gamma \vdash \mt{open} \; M \leadsto \Gamma, \mathcal O(M, S)}{ + \Gamma \vdash M : S +}$$ + +$$\infer{\Gamma \vdash \mt{constraint} \; c_1 \sim c_2 \leadsto \Gamma}{ + \Gamma \vdash c_1 :: \{\kappa\} + & \Gamma \vdash c_2 :: \{\kappa\} + & \Gamma \vdash c_1 \sim c_2 +} +\quad \infer{\Gamma \vdash \mt{open} \; \mt{constraints} \; M \leadsto \Gamma, \mathcal O_c(M, S)}{ + \Gamma \vdash M : S +}$$ + +$$\infer{\Gamma \vdash \mt{table} \; x : c \leadsto \Gamma, x : \mt{Basis}.\mt{sql\_table} \; c}{ + \Gamma \vdash c :: \{\mt{Type}\} +} +\quad \infer{\Gamma \vdash \mt{sequence} \; x \leadsto \Gamma, x : \mt{Basis}.\mt{sql\_sequence}}{}$$ + +$$\infer{\Gamma \vdash \mt{cookie} \; x : \tau \leadsto \Gamma, x : \mt{Basis}.\mt{http\_cookie} \; \tau}{ + \Gamma \vdash \tau :: \mt{Type} +}$$ + +$$\infer{\Gamma \vdash \mt{class} \; x = c \leadsto \Gamma, x :: \mt{Type} \to \mt{Type} = c}{ + \Gamma \vdash c :: \mt{Type} \to \mt{Type} +}$$ + +$$\infer{\overline{y}; x; \Gamma \vdash \cdot \leadsto \Gamma}{} +\quad \infer{\overline{y}; x; \Gamma \vdash X \mid \overline{dc} \leadsto \Gamma', X : \overline{y ::: \mt{Type}} \to x \; \overline{y}}{ + \overline{y}; x; \Gamma \vdash \overline{dc} \leadsto \Gamma' +} +\quad \infer{\overline{y}; x; \Gamma \vdash X \; \mt{of} \; \tau \mid \overline{dc} \leadsto \Gamma', X : \overline{y ::: \mt{Type}} \to \tau \to x \; \overline{y}}{ + \overline{y}; x; \Gamma \vdash \overline{dc} \leadsto \Gamma' +}$$ + \end{document} \ No newline at end of file -- cgit v1.2.3 From 022c9806c7c5d74195c0bc654c4f064384cb1d42 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 29 Nov 2008 12:58:58 -0500 Subject: Signature compatibility --- doc/manual.tex | 36 ++++++++++++++++++++++++++++++++++-- 1 file changed, 34 insertions(+), 2 deletions(-) diff --git a/doc/manual.tex b/doc/manual.tex index 4df95230..2c8379d5 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -245,8 +245,7 @@ Since there is significant mutual recursion among the judgments, we introduce th \item $\Gamma \vdash e : \tau$ is a standard typing judgment. \item $\Gamma \vdash p \leadsto \Gamma; \tau$ combines typing of patterns with calculation of which new variables they bind. \item $\Gamma \vdash d \leadsto \Gamma$ expresses how a declaration modifies a context. We overload this judgment to apply to sequences of declarations. -\item $\Gamma \vdash S$ is the signature validity judgment. -\item $\Gamma \vdash S \leq S$ is the signature compatibility judgment. +\item $\Gamma \vdash S \leq S$ is the signature compatibility judgment. We write $\Gamma \vdash S$ as shorthand for $\Gamma \vdash S \leq S$. \item $\Gamma \vdash M : S$ is the module signature checking judgment. \item $\mt{proj}(M, S, V)$ is a partial function for projecting a signature item from a signature $S$, given the module $M$ that we project from. $V$ may be $\mt{con} \; x$, $\mt{datatype} \; x$, $\mt{val} \; x$, $\mt{signature} \; X$, or $\mt{structure} \; X$. The parameter $M$ is needed because the projected signature item may refer to other items of $S$. \end{itemize} @@ -600,4 +599,37 @@ $$\infer{\overline{y}; x; \Gamma \vdash \cdot \leadsto \Gamma}{} \overline{y}; x; \Gamma \vdash \overline{dc} \leadsto \Gamma' }$$ +\subsection{Signature Compatibility} + +$$\infer{\Gamma \vdash S \equiv S}{} +\quad \infer{\Gamma \vdash S_1 \equiv S_2}{ + \Gamma \vdash S_2 \equiv S_1 +} +\quad \infer{\Gamma \vdash X \equiv S}{ + X = S \in \Gamma +} +\quad \infer{\Gamma \vdash M.X \equiv S}{ + \Gamma \vdash M : S' + & \mt{proj}(M, S', \mt{signature} \; X) = S +}$$ + +$$\infer{\Gamma \vdash S \; \mt{where} \; \mt{con} \; x = c \equiv \mt{sig} \; \overline{s^1} \; \mt{con} \; x :: \kappa = c \; \overline{s_2} \; \mt{end}}{ + \Gamma \vdash S \equiv \mt{sig} \; \overline{s^1} \; \mt{con} \; x :: \kappa \; \overline{s_2} \; \mt{end} + & \Gamma \vdash c :: \kappa +}$$ + +$$\infer{\Gamma \vdash S_1 \leq S_2}{ + \Gamma \vdash S_1 \equiv S_2 +} +\quad \infer{\Gamma \vdash \mt{sig} \; \overline{s} \; \mt{end} \leq \mt{sig} \; \mt{end}}{} +\quad \infer{\Gamma \vdash \mt{sig} \; \overline{s^1} \; s \; \overline{s^2} \; \mt{end} \leq \mt{sig} \; s' \; \overline{s} \; \mt{end}}{ + \Gamma \vdash s \leq s'; \Gamma' + & \Gamma' \vdash \mt{sig} \; \overline{s^1} \; s \; \overline{s^2} \; \mt{end} \leq \mt{sig} \; \overline{s} \; \mt{end} +}$$ + +$$\infer{\Gamma \vdash \mt{functor} (X : S_1) : S_2 \leq \mt{functor} (X : S'_1) : S'_2}{ + \Gamma \vdash S'_1 \leq S_1 + & \Gamma, X : S'_1 \vdash S_2 \leq S'_2 +}$$ + \end{document} \ No newline at end of file -- cgit v1.2.3 From 509cd9c3d6cb02ff1d23a831979208e327668432 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 29 Nov 2008 13:50:53 -0500 Subject: Signature compatibility --- doc/manual.tex | 191 ++++++++++++++++++++++++++++++++++++++++++++++++--------- 1 file changed, 162 insertions(+), 29 deletions(-) diff --git a/doc/manual.tex b/doc/manual.tex index 2c8379d5..ed41acaa 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -244,10 +244,11 @@ Since there is significant mutual recursion among the judgments, we introduce th \item $\Gamma \vdash c \equiv c$ proves the computational equivalence of two constructors. This is often called a \emph{definitional equality} in the world of type theory. \item $\Gamma \vdash e : \tau$ is a standard typing judgment. \item $\Gamma \vdash p \leadsto \Gamma; \tau$ combines typing of patterns with calculation of which new variables they bind. -\item $\Gamma \vdash d \leadsto \Gamma$ expresses how a declaration modifies a context. We overload this judgment to apply to sequences of declarations. +\item $\Gamma \vdash d \leadsto \Gamma$ expresses how a declaration modifies a context. We overload this judgment to apply to sequences of declarations, as well as to signature items and sequences of signature items. +\item $\Gamma \vdash S \equiv S$ is the signature equivalence judgment. \item $\Gamma \vdash S \leq S$ is the signature compatibility judgment. We write $\Gamma \vdash S$ as shorthand for $\Gamma \vdash S \leq S$. \item $\Gamma \vdash M : S$ is the module signature checking judgment. -\item $\mt{proj}(M, S, V)$ is a partial function for projecting a signature item from a signature $S$, given the module $M$ that we project from. $V$ may be $\mt{con} \; x$, $\mt{datatype} \; x$, $\mt{val} \; x$, $\mt{signature} \; X$, or $\mt{structure} \; X$. The parameter $M$ is needed because the projected signature item may refer to other items of $S$. +\item $\mt{proj}(M, \overline{s}, V)$ is a partial function for projecting a signature item from $\overline{s}$, given the module $M$ that we project from. $V$ may be $\mt{con} \; x$, $\mt{datatype} \; x$, $\mt{val} \; x$, $\mt{signature} \; X$, or $\mt{structure} \; X$. The parameter $M$ is needed because the projected signature item may refer to other items from $\overline{s}$. \end{itemize} \subsection{Kinding} @@ -263,12 +264,12 @@ $$\infer{\Gamma \vdash (c) :: \kappa :: \kappa}{ }$$ $$\infer{\Gamma \vdash M.x :: \kappa}{ - \Gamma \vdash M : S - & \mt{proj}(M, S, \mt{con} \; x) = \kappa + \Gamma \vdash M : \mt{sig} \; \overline{s} \; \mt{end} + & \mt{proj}(M, \overline{s}, \mt{con} \; x) = \kappa } \quad \infer{\Gamma \vdash M.x :: \kappa}{ - \Gamma \vdash M : S - & \mt{proj}(M, S, \mt{con} \; x) = (\kappa, c) + \Gamma \vdash M : \mt{sig} \; \overline{s} \; \mt{end} + & \mt{proj}(M, \overline{s}, \mt{con} \; x) = (\kappa, c) }$$ $$\infer{\Gamma \vdash \tau_1 \to \tau_2 :: \mt{Type}}{ @@ -374,8 +375,8 @@ $$\infer{\Gamma \vdash x \equiv c}{ x :: \kappa = c \in \Gamma } \quad \infer{\Gamma \vdash M.x \equiv c}{ - \Gamma \vdash M : S - & \mt{proj}(M, S, \mt{con} \; x) = (\kappa, c) + \Gamma \vdash M : \mt{sig} \; \overline{s} \; \mt{end} + & \mt{proj}(M, \overline{s}, \mt{con} \; x) = (\kappa, c) } \quad \infer{\Gamma \vdash (\overline c).i \equiv c_i}{}$$ @@ -417,15 +418,15 @@ $$\infer{\Gamma \vdash x : \mathcal I(\tau)}{ x : \tau \in \Gamma } \quad \infer{\Gamma \vdash M.x : \mathcal I(\tau)}{ - \Gamma \vdash M : S - & \mt{proj}(M, S, \mt{val} \; x) = \tau + \Gamma \vdash M : \mt{sig} \; \overline{s} \; \mt{end} + & \mt{proj}(M, \overline{s}, \mt{val} \; x) = \tau } \quad \infer{\Gamma \vdash X : \mathcal I(\tau)}{ X : \tau \in \Gamma } \quad \infer{\Gamma \vdash M.X : \mathcal I(\tau)}{ - \Gamma \vdash M : S - & \mt{proj}(M, S, \mt{val} \; X) = \tau + \Gamma \vdash M : \mt{sig} \; \overline{s} \; \mt{end} + & \mt{proj}(M, \overline{s}, \mt{val} \; X) = \tau }$$ $$\infer{\Gamma \vdash e_1 \; e_2 : \tau_2}{ @@ -502,14 +503,14 @@ $$\infer{\Gamma \vdash X \leadsto \Gamma; \overline{[x_i \mapsto \tau'_i]}\tau}{ }$$ $$\infer{\Gamma \vdash M.X \leadsto \Gamma; \overline{[x_i \mapsto \tau'_i]}\tau}{ - \Gamma \vdash M : S - & \mt{proj}(M, S, \mt{val} \; X) = \overline{x ::: \mt{Type}} \to \tau + \Gamma \vdash M : \mt{sig} \; \overline{s} \; \mt{end} + & \mt{proj}(M, \overline{s}, \mt{val} \; X) = \overline{x ::: \mt{Type}} \to \tau & \textrm{$\tau$ not a function type} }$$ $$\infer{\Gamma \vdash M.X \; p \leadsto \Gamma'; \overline{[x_i \mapsto \tau'_i]}\tau}{ - \Gamma \vdash M : S - & \mt{proj}(M, S, \mt{val} \; X) = \overline{x ::: \mt{Type}} \to \tau'' \to \tau + \Gamma \vdash M : \mt{sig} \; \overline{s} \; \mt{end} + & \mt{proj}(M, \overline{s}, \mt{val} \; X) = \overline{x ::: \mt{Type}} \to \tau'' \to \tau & \Gamma \vdash p \leadsto \Gamma'; \overline{[x_i \mapsto \tau'_i]}\tau'' }$$ @@ -528,7 +529,9 @@ We use an auxiliary judgment $\overline{y}; x; \Gamma \vdash \overline{dc} \lead This is the first judgment where we deal with type classes, for the $\mt{class}$ declaration form. We will omit their special handling in this formal specification. In the compiler, a set of available type classes and their instances is maintained, and these instances are used to fill in expression wildcards. -We presuppose the existence of a function $\mathcal O$, where $\mathcal(M, S)$ implements the $\mt{open}$ declaration by producing a context with the appropriate entry for each available component of module $M$ with signature $S$. Where possible, $\mathcal O$ uses ``transparent'' entries (e.g., an abstract type $M.x$ is mapped to $x :: \mt{Type} = M.x$), so that the relationship with $M$ is maintained. A related function $\mathcal O_c$ builds a context containing the disjointness constraints found in $S$. +We presuppose the existence of a function $\mathcal O$, where $\mathcal(M, \overline{s})$ implements the $\mt{open}$ declaration by producing a context with the appropriate entry for each available component of module $M$ with signature items $\overline{s}$. Where possible, $\mathcal O$ uses ``transparent'' entries (e.g., an abstract type $M.x$ is mapped to $x :: \mt{Type} = M.x$), so that the relationship with $M$ is maintained. A related function $\mathcal O_c$ builds a context containing the disjointness constraints found in $S$. + +We write $\kappa_1^n \to \kappa$ as a shorthand, where $\kappa_1^0 \to \kappa = \kappa$ and $\kappa_1^{n+1} \to \kappa_2 = \kappa_1 \to (\kappa_1^n \to \kappa_2)$. We write $\mt{len}(\overline{y})$ for the length of vector $\overline{y}$ of variables. $$\infer{\Gamma \vdash \cdot \leadsto \Gamma}{} \quad \infer{\Gamma \vdash d, \overline{d} \leadsto \Gamma''}{ @@ -544,8 +547,8 @@ $$\infer{\Gamma \vdash \mt{con} \; x :: \kappa = c \leadsto \Gamma, x :: \kappa }$$ $$\infer{\Gamma \vdash \mt{datatype} \; x = \mt{datatype} \; M.z \leadsto \Gamma'}{ - \Gamma \vdash M : S - & \mt{proj}(M, S, \mt{datatype} \; z) = (\overline{y}, \overline{dc}) + \Gamma \vdash M : \mt{sig} \; \overline{s} \; \mt{end} + & \mt{proj}(M, \overline{s}, \mt{datatype} \; z) = (\overline{y}, \overline{dc}) & \overline{y}; x; \Gamma, x :: \mt{Type}^{\mt{len}(\overline y)} \to \mt{Type} = M.z \vdash \overline{dc} \leadsto \Gamma' }$$ @@ -561,12 +564,12 @@ $$\infer{\Gamma \vdash \mt{val} \; \mt{rec} \; \overline{x : \tau = e} \leadsto $$\infer{\Gamma \vdash \mt{structure} \; X : S = M \leadsto \Gamma, X : S}{ \Gamma \vdash M : S } -\quad \infer{\Gamma \vdash \mt{siganture} \; X = S \leadsto \Gamma, X = S}{ +\quad \infer{\Gamma \vdash \mt{signature} \; X = S \leadsto \Gamma, X = S}{ \Gamma \vdash S }$$ -$$\infer{\Gamma \vdash \mt{open} \; M \leadsto \Gamma, \mathcal O(M, S)}{ - \Gamma \vdash M : S +$$\infer{\Gamma \vdash \mt{open} \; M \leadsto \Gamma, \mathcal O(M, \overline{s})}{ + \Gamma \vdash M : \mt{sig} \; \overline{s} \; \mt{end} }$$ $$\infer{\Gamma \vdash \mt{constraint} \; c_1 \sim c_2 \leadsto \Gamma}{ @@ -574,8 +577,8 @@ $$\infer{\Gamma \vdash \mt{constraint} \; c_1 \sim c_2 \leadsto \Gamma}{ & \Gamma \vdash c_2 :: \{\kappa\} & \Gamma \vdash c_1 \sim c_2 } -\quad \infer{\Gamma \vdash \mt{open} \; \mt{constraints} \; M \leadsto \Gamma, \mathcal O_c(M, S)}{ - \Gamma \vdash M : S +\quad \infer{\Gamma \vdash \mt{open} \; \mt{constraints} \; M \leadsto \Gamma, \mathcal O_c(M, \overline{s})}{ + \Gamma \vdash M : \mt{sig} \; \overline{s} \; \mt{end} }$$ $$\infer{\Gamma \vdash \mt{table} \; x : c \leadsto \Gamma, x : \mt{Basis}.\mt{sql\_table} \; c}{ @@ -599,8 +602,62 @@ $$\infer{\overline{y}; x; \Gamma \vdash \cdot \leadsto \Gamma}{} \overline{y}; x; \Gamma \vdash \overline{dc} \leadsto \Gamma' }$$ +\subsection{Signature Item Typing} + +We appeal to a signature item analogue of the $\mathcal O$ function from the last subsection. + +$$\infer{\Gamma \vdash \cdot \leadsto \Gamma}{} +\quad \infer{\Gamma \vdash s, \overline{s} \leadsto \Gamma''}{ + \Gamma \vdash s \leadsto \Gamma' + & \Gamma' \vdash \overline{s} \leadsto \Gamma'' +}$$ + +$$\infer{\Gamma \vdash \mt{con} \; x :: \kappa \leadsto \Gamma, x :: \kappa}{} +\quad \infer{\Gamma \vdash \mt{con} \; x :: \kappa = c \leadsto \Gamma, x :: \kappa = c}{ + \Gamma \vdash c :: \kappa +} +\quad \infer{\Gamma \vdash \mt{datatype} \; x \; \overline{y} = \overline{dc} \leadsto \Gamma'}{ + \overline{y}; x; \Gamma, x :: \mt{Type}^{\mt{len}(\overline y)} \to \mt{Type} \vdash \overline{dc} \leadsto \Gamma' +}$$ + +$$\infer{\Gamma \vdash \mt{datatype} \; x = \mt{datatype} \; M.z \leadsto \Gamma'}{ + \Gamma \vdash M : \mt{sig} \; \overline{s} \; \mt{end} + & \mt{proj}(M, \overline{s}, \mt{datatype} \; z) = (\overline{y}, \overline{dc}) + & \overline{y}; x; \Gamma, x :: \mt{Type}^{\mt{len}(\overline y)} \to \mt{Type} = M.z \vdash \overline{dc} \leadsto \Gamma' +}$$ + +$$\infer{\Gamma \vdash \mt{val} \; x : \tau \leadsto \Gamma, x : \tau}{ + \Gamma \vdash \tau :: \mt{Type} +}$$ + +$$\infer{\Gamma \vdash \mt{structure} \; X : S \leadsto \Gamma, X : S}{ + \Gamma \vdash S +} +\quad \infer{\Gamma \vdash \mt{signature} \; X = S \leadsto \Gamma, X = S}{ + \Gamma \vdash S +}$$ + +$$\infer{\Gamma \vdash \mt{include} \; S \leadsto \Gamma, \mathcal O(\overline{s})}{ + \Gamma \vdash S + & \Gamma \vdash S \equiv \mt{sig} \; \overline{s} \; \mt{end} +}$$ + +$$\infer{\Gamma \vdash \mt{constraint} \; c_1 \sim c_2 \leadsto \Gamma, c_1 \sim c_2}{ + \Gamma \vdash c_1 :: \{\kappa\} + & \Gamma \vdash c_2 :: \{\kappa\} +}$$ + +$$\infer{\Gamma \vdash \mt{class} \; x = c \leadsto \Gamma, x :: \mt{Type} \to \mt{Type} = c}{ + \Gamma \vdash c :: \mt{Type} \to \mt{Type} +} +\quad \infer{\Gamma \vdash \mt{class} \; x \leadsto \Gamma, x :: \mt{Type} \to \mt{Type}}{}$$ + \subsection{Signature Compatibility} +To simplify the judgments in this section, we assume that all signatures are alpha-varied as necessary to avoid including mmultiple bindings for the same identifier. This is in addition to the usual alpha-variation of locally-bound variables. + +We rely on a judgment $\Gamma \vdash \overline{s} \leq s'$, which expresses the occurrence in signature items $\overline{s}$ of an item compatible with $s'$. We also use a judgment $\Gamma \vdash \overline{dc} \leq \overline{dc}$, which expresses compatibility of datatype definitions. + $$\infer{\Gamma \vdash S \equiv S}{} \quad \infer{\Gamma \vdash S_1 \equiv S_2}{ \Gamma \vdash S_2 \equiv S_1 @@ -609,22 +666,34 @@ $$\infer{\Gamma \vdash S \equiv S}{} X = S \in \Gamma } \quad \infer{\Gamma \vdash M.X \equiv S}{ - \Gamma \vdash M : S' - & \mt{proj}(M, S', \mt{signature} \; X) = S + \Gamma \vdash M : \mt{sig} \; \overline{s} \; \mt{end} + & \mt{proj}(M, \overline{s}, \mt{signature} \; X) = S }$$ $$\infer{\Gamma \vdash S \; \mt{where} \; \mt{con} \; x = c \equiv \mt{sig} \; \overline{s^1} \; \mt{con} \; x :: \kappa = c \; \overline{s_2} \; \mt{end}}{ \Gamma \vdash S \equiv \mt{sig} \; \overline{s^1} \; \mt{con} \; x :: \kappa \; \overline{s_2} \; \mt{end} & \Gamma \vdash c :: \kappa +} +\quad \infer{\Gamma \vdash \mt{sig} \; \overline{s^1} \; \mt{include} \; S \; \overline{s^2} \; \mt{end} \equiv \mt{sig} \; \overline{s^1} \; \overline{s} \; \overline{s^2} \; \mt{end}}{ + \Gamma \vdash S \equiv \mt{sig} \; \overline{s} \; \mt{end} }$$ $$\infer{\Gamma \vdash S_1 \leq S_2}{ \Gamma \vdash S_1 \equiv S_2 } \quad \infer{\Gamma \vdash \mt{sig} \; \overline{s} \; \mt{end} \leq \mt{sig} \; \mt{end}}{} -\quad \infer{\Gamma \vdash \mt{sig} \; \overline{s^1} \; s \; \overline{s^2} \; \mt{end} \leq \mt{sig} \; s' \; \overline{s} \; \mt{end}}{ - \Gamma \vdash s \leq s'; \Gamma' - & \Gamma' \vdash \mt{sig} \; \overline{s^1} \; s \; \overline{s^2} \; \mt{end} \leq \mt{sig} \; \overline{s} \; \mt{end} +\quad \infer{\Gamma \vdash \mt{sig} \; \overline{s} \; \mt{end} \leq \mt{sig} \; s' \; \overline{s'} \; \mt{end}}{ + \Gamma \vdash \overline{s} \leq s' + & \Gamma \vdash s' \leadsto \Gamma' + & \Gamma' \vdash \mt{sig} \; \overline{s} \; \mt{end} \leq \mt{sig} \; \overline{s'} \; \mt{end} +}$$ + +$$\infer{\Gamma \vdash s \; \overline{s} \leq s'}{ + \Gamma \vdash s \leq s' +} +\quad \infer{\Gamma \vdash s \; \overline{s} \leq s'}{ + \Gamma \vdash s \leadsto \Gamma' + & \Gamma' \vdash \overline{s} \leq s' }$$ $$\infer{\Gamma \vdash \mt{functor} (X : S_1) : S_2 \leq \mt{functor} (X : S'_1) : S'_2}{ @@ -632,4 +701,68 @@ $$\infer{\Gamma \vdash \mt{functor} (X : S_1) : S_2 \leq \mt{functor} (X : S'_1) & \Gamma, X : S'_1 \vdash S_2 \leq S'_2 }$$ +$$\infer{\Gamma \vdash \mt{con} \; x :: \kappa \leq \mt{con} \; x :: \kappa}{} +\quad \infer{\Gamma \vdash \mt{con} \; x :: \kappa = c \leq \mt{con} \; x :: \kappa}{} +\quad \infer{\Gamma \vdash \mt{datatype} \; x \; \overline{y} = \overline{dc} \leq \mt{con} \; x :: \mt{Type}}{}$$ + +$$\infer{\Gamma \vdash \mt{datatype} \; x = \mt{datatype} \; M.z \leq \mt{con} \; x :: \mt{Type}^{\mt{len}(y)} \to \mt{Type}}{ + \Gamma \vdash M : \mt{sig} \; \overline{s} \; \mt{end} + & \mt{proj}(M, \overline{s}, \mt{datatype} \; z) = (\overline{y}, \overline{dc}) +}$$ + +$$\infer{\Gamma \vdash \mt{class} \; x \leq \mt{con} \; x :: \mt{Type} \to \mt{Type}}{} +\quad \infer{\Gamma \vdash \mt{class} \; x = c \leq \mt{con} \; x :: \mt{Type} \to \mt{Type}}{}$$ + +$$\infer{\Gamma \vdash \mt{con} \; x :: \kappa = c_1 \leq \mt{con} \; x :: \mt{\kappa} = c_2}{ + \Gamma \vdash c_1 \equiv c_2 +} +\quad \infer{\Gamma \vdash \mt{class} \; x = c_1 \leq \mt{con} \; x :: \mt{Type} \to \mt{Type} = c_2}{ + \Gamma \vdash c_1 \equiv c_2 +}$$ + +$$\infer{\Gamma \vdash \mt{datatype} \; x \; \overline{y} = \overline{dc} \leq \mt{datatype} \; x \; \overline{y} = \overline{dc'}}{ + \Gamma, \overline{y :: \mt{Type}} \vdash \overline{dc} \leq \overline{dc'} +}$$ + +$$\infer{\Gamma \vdash \mt{datatype} \; x = \mt{datatype} \; M.z \leq \mt{datatype} \; x \; \overline{y} = \overline{dc'}}{ + \Gamma \vdash M : \mt{sig} \; \overline{s} \; \mt{end} + & \mt{proj}(M, \overline{s}, \mt{datatype} \; z) = (\overline{y}, \overline{dc}) + & \Gamma, \overline{y :: \mt{Type}} \vdash \overline{dc} \leq \overline{dc'} +}$$ + +$$\infer{\Gamma \vdash \cdot \leq \cdot}{} +\quad \infer{\Gamma \vdash X; \overline{dc} \leq X; \overline{dc'}}{ + \Gamma \vdash \overline{dc} \leq \overline{dc'} +} +\quad \infer{\Gamma \vdash X \; \mt{of} \; \tau_1; \overline{dc} \leq X \; \mt{of} \; \tau_2; \overline{dc'}}{ + \Gamma \vdash \tau_1 \equiv \tau_2 + & \Gamma \vdash \overline{dc} \leq \overline{dc'} +}$$ + +$$\infer{\Gamma \vdash \mt{datatype} \; x = \mt{datatype} \; M.z \leq \mt{datatype} \; x = \mt{datatype} \; M'.z'}{ + \Gamma \vdash M.z \equiv M'.z' +}$$ + +$$\infer{\Gamma \vdash \mt{val} \; x : \tau_1 \leq \mt{val} \; x : \tau_2}{ + \Gamma \vdash \tau_1 \equiv \tau_2 +} +\quad \infer{\Gamma \vdash \mt{structure} \; X : S_1 \leq \mt{structure} \; X : S_2}{ + \Gamma \vdash S_1 \leq S_2 +} +\quad \infer{\Gamma \vdash \mt{signature} \; X = S_1 \leq \mt{signature} \; X = S_2}{ + \Gamma \vdash S_1 \leq S_2 + & \Gamma \vdash S_2 \leq S_1 +}$$ + +$$\infer{\Gamma \vdash \mt{constraint} \; c_1 \sim c_2 \leq \mt{constraint} \; c'_1 \sim c'_2}{ + \Gamma \vdash c_1 \equiv c'_1 + & \Gamma \vdash c_2 \equiv c'_2 +}$$ + +$$\infer{\Gamma \vdash \mt{class} \; x \leq \mt{class} \; x}{} +\quad \infer{\Gamma \vdash \mt{class} \; x = c \leq \mt{class} \; x}{} +\quad \infer{\Gamma \vdash \mt{class} \; x = c_1 \leq \mt{class} \; x = c_2}{ + \Gamma \vdash c_1 \equiv c_2 +}$$ + \end{document} \ No newline at end of file -- cgit v1.2.3 From 2cf99ae8367d64360d18f7e838f905419f4c80ef Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 29 Nov 2008 14:09:43 -0500 Subject: Module typing --- doc/manual.tex | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 50 insertions(+) diff --git a/doc/manual.tex b/doc/manual.tex index ed41acaa..53a2b787 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -765,4 +765,54 @@ $$\infer{\Gamma \vdash \mt{class} \; x \leq \mt{class} \; x}{} \Gamma \vdash c_1 \equiv c_2 }$$ +\subsection{Module Typing} + +We use a helper function $\mt{sigOf}$, which converts declarations and sequences of declarations into their principal signature items and sequences of signature items, respectively. + +$$\infer{\Gamma \vdash M : S}{ + \Gamma \vdash M : S' + & \Gamma \vdash S' \leq S +} +\quad \infer{\Gamma \vdash \mt{struct} \; \overline{d} \; \mt{end} : \mt{sig} \; \mt{sigOf}(\overline{d}) \; \mt{end}}{ + \Gamma \vdash \overline{d} \leadsto \Gamma' +} +\quad \infer{\Gamma \vdash X : S}{ + X : S \in \Gamma +}$$ + +$$\infer{\Gamma \vdash M.X : S}{ + \Gamma \vdash M : \mt{sig} \; \overline{s} \; \mt{end} + & \mt{proj}(M, \overline{s}, \mt{structure} \; X) = S +}$$ + +$$\infer{\Gamma \vdash M_1(M_2) : [X \mapsto M_2]S_2}{ + \Gamma \vdash M_1 : \mt{functor}(X : S_1) : S_2 + & \Gamma \vdash M_2 : S_1 +} +\quad \infer{\Gamma \vdash \mt{functor} (X : S_1) : S_2 = M : \mt{functor} (X : S_1) : S_2}{ + \Gamma \vdash S_1 + & \Gamma, X : S_1 \vdash S_2 + & \Gamma, X : S_1 \vdash M : S_2 +}$$ + +\begin{eqnarray*} + \mt{sigOf}(\cdot) &=& \cdot \\ + \mt{sigOf}(s \; \overline{s'}) &=& \mt{sigOf}(s) \; \mt{sigOf}(\overline{s'}) \\ + \\ + \mt{sigOf}(\mt{con} \; x :: \kappa = c) &=& \mt{con} \; x :: \kappa = c \\ + \mt{sigOf}(\mt{datatype} \; x \; \overline{y} = \overline{dc}) &=& \mt{datatype} \; x \; \overline{y} = \overline{dc} \\ + \mt{sigOf}(\mt{datatype} \; x = \mt{datatype} \; M.z) &=& \mt{datatype} \; x = \mt{datatype} \; M.z \\ + \mt{sigOf}(\mt{val} \; x : \tau = e) &=& \mt{val} \; x : \tau \\ + \mt{sigOf}(\mt{val} \; \mt{rec} \; \overline{x : \tau = e}) &=& \overline{\mt{val} \; x : \tau} \\ + \mt{sigOf}(\mt{structure} \; X : S = M) &=& \mt{structure} \; X : S \\ + \mt{sigOf}(\mt{signature} \; X = S) &=& \mt{signature} \; X = S \\ + \mt{sigOf}(\mt{open} \; M) &=& \mt{include} \; S \textrm{ (where $\Gamma \vdash M : S$)} \\ + \mt{sigOf}(\mt{constraint} \; c_1 \sim c_2) &=& \mt{constraint} \; c_1 \sim c_2 \\ + \mt{sigOf}(\mt{open} \; \mt{constraints} \; M) &=& \cdot \\ + \mt{sigOf}(\mt{table} \; x : c) &=& \mt{table} \; x : c \\ + \mt{sigOf}(\mt{sequence} \; x) &=& \mt{sequence} \; x \\ + \mt{sigOf}(\mt{cookie} \; x : \tau) &=& \mt{cookie} \; x : \tau \\ + \mt{sigOf}(\mt{class} \; x = c) &=& \mt{class} \; x = c \\ +\end{eqnarray*} + \end{document} \ No newline at end of file -- cgit v1.2.3 From bcddef561bc3d980de9cbec25605accb2334c115 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 29 Nov 2008 14:32:33 -0500 Subject: selfify --- doc/manual.tex | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/doc/manual.tex b/doc/manual.tex index 53a2b787..eac33bc6 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -249,6 +249,7 @@ Since there is significant mutual recursion among the judgments, we introduce th \item $\Gamma \vdash S \leq S$ is the signature compatibility judgment. We write $\Gamma \vdash S$ as shorthand for $\Gamma \vdash S \leq S$. \item $\Gamma \vdash M : S$ is the module signature checking judgment. \item $\mt{proj}(M, \overline{s}, V)$ is a partial function for projecting a signature item from $\overline{s}$, given the module $M$ that we project from. $V$ may be $\mt{con} \; x$, $\mt{datatype} \; x$, $\mt{val} \; x$, $\mt{signature} \; X$, or $\mt{structure} \; X$. The parameter $M$ is needed because the projected signature item may refer to other items from $\overline{s}$. +\item $\mt{selfify}(M, \overline{s})$ adds information to signature items $\overline{s}$ to reflect the fact that we are concerned with the particular module $M$. This function is overloaded to work over individual signature items as well. \end{itemize} \subsection{Kinding} @@ -563,8 +564,13 @@ $$\infer{\Gamma \vdash \mt{val} \; \mt{rec} \; \overline{x : \tau = e} \leadsto $$\infer{\Gamma \vdash \mt{structure} \; X : S = M \leadsto \Gamma, X : S}{ \Gamma \vdash M : S + & \textrm{ ($M$ not a $\mt{struct} \; \ldots \; \mt{end}$)} } -\quad \infer{\Gamma \vdash \mt{signature} \; X = S \leadsto \Gamma, X = S}{ +\quad \infer{\Gamma \vdash \mt{structure} \; X : S = \mt{struct} \; \overline{d} \; \mt{end} \leadsto \Gamma, X : \mt{selfify}(X, \overline{s})}{ + \Gamma \vdash \mt{struct} \; \overline{d} \; \mt{end} : \mt{sig} \; \overline{s} \; \mt{end} +}$$ + +$$\infer{\Gamma \vdash \mt{signature} \; X = S \leadsto \Gamma, X = S}{ \Gamma \vdash S }$$ @@ -815,4 +821,21 @@ $$\infer{\Gamma \vdash M_1(M_2) : [X \mapsto M_2]S_2}{ \mt{sigOf}(\mt{class} \; x = c) &=& \mt{class} \; x = c \\ \end{eqnarray*} +\begin{eqnarray*} + \mt{selfify}(M, \cdot) &=& \cdot \\ + \mt{selfify}(M, s \; \overline{s'}) &=& \mt{selfify}(M, \sigma, s) \; \mt{selfify}(M, \overline{s'}) \\ + \\ + \mt{selfify}(M, \mt{con} \; x :: \kappa) &=& \mt{con} \; x :: \kappa = M.x \\ + \mt{selfify}(M, \mt{con} \; x :: \kappa = c) &=& \mt{con} \; x :: \kappa = c \\ + \mt{selfify}(M, \mt{datatype} \; x \; \overline{y} = \overline{dc}) &=& \mt{datatype} \; x \; \overline{y} = \mt{datatype} \; M.x \\ + \mt{selfify}(M, \mt{datatype} \; x = \mt{datatype} \; M'.z) &=& \mt{datatype} \; x = \mt{datatype} \; M'.z \\ + \mt{selfify}(M, \mt{val} \; x : \tau) &=& \mt{val} \; x : \tau \\ + \mt{selfify}(M, \mt{structure} \; X : S) &=& \mt{structure} \; X : \mt{selfify}(M.X, \overline{s}) \textrm{ (where $\Gamma \vdash S \equiv \mt{sig} \; \overline{s} \; \mt{end}$)} \\ + \mt{selfify}(M, \mt{signature} \; X = S) &=& \mt{signature} \; X = S \\ + \mt{selfify}(M, \mt{include} \; S) &=& \mt{include} \; S \\ + \mt{selfify}(M, \mt{constraint} \; c_1 \sim c_2) &=& \mt{constraint} \; c_1 \sim c_2 \\ + \mt{selfify}(M, \mt{class} \; x) &=& \mt{class} \; x = M.x \\ + \mt{selfify}(M, \mt{class} \; x = c) &=& \mt{class} \; x = c \\ +\end{eqnarray*} + \end{document} \ No newline at end of file -- cgit v1.2.3 From bd43499d17cec3123d5462233ea487b41e77a80f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 29 Nov 2008 15:04:57 -0500 Subject: Module projection --- .hgignore | 1 + doc/manual.tex | 41 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 42 insertions(+) diff --git a/.hgignore b/.hgignore index fe5b6659..4e578224 100644 --- a/.hgignore +++ b/.hgignore @@ -32,3 +32,4 @@ demo/demo.* *.dvi *.pdf *.ps +*.toc diff --git a/doc/manual.tex b/doc/manual.tex index eac33bc6..713bbe60 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -15,6 +15,8 @@ \maketitle +\tableofcontents + \section{Ur Syntax} In this section, we describe the syntax of Ur, deferring to a later section discussion of most of the syntax specific to SQL and XML. The sole exceptions are the declaration forms for tables, sequences, and cookies. @@ -838,4 +840,43 @@ $$\infer{\Gamma \vdash M_1(M_2) : [X \mapsto M_2]S_2}{ \mt{selfify}(M, \mt{class} \; x = c) &=& \mt{class} \; x = c \\ \end{eqnarray*} +\subsection{Module Projection} + +\begin{eqnarray*} + \mt{proj}(M, \mt{con} \; x :: \kappa \; \overline{s}, \mt{con} \; x) &=& \kappa \\ + \mt{proj}(M, \mt{con} \; x :: \kappa = c \; \overline{s}, \mt{con} \; x) &=& (\kappa, c) \\ + \mt{proj}(M, \mt{datatype} \; x \; \overline{y} = \overline{dc} \; \overline{s}, \mt{con} \; x) &=& \mt{Type}^{\mt{len}(\overline{y})} \to \mt{Type} \\ + \mt{proj}(M, \mt{datatype} \; x = \mt{datatype} \; M'.z \; \overline{s}, \mt{con} \; x) &=& (\mt{Type}^{\mt{len}(\overline{y})} \to \mt{Type}, M'.z) \textrm{ (where $\Gamma \vdash M' : \mt{sig} \; \overline{s'} \; \mt{end}$} \\ + && \textrm{and $\mt{proj}(M', \overline{s'}, \mt{datatype} \; z) = (\overline{y}, \overline{dc})$)} \\ + \mt{proj}(M, \mt{class} \; x \; \overline{s}, \mt{con} \; x) &=& \mt{Type} \to \mt{Type} \\ + \mt{proj}(M, \mt{class} \; x = c \; \overline{s}, \mt{con} \; x) &=& (\mt{Type} \to \mt{Type}, c) \\ + \\ + \mt{proj}(M, \mt{datatype} \; x \; \overline{y} = \overline{dc} \; \overline{s}, \mt{datatype} \; x) &=& (\overline{y}, \overline{dc}) \\ + \mt{proj}(M, \mt{datatype} \; x = \mt{datatype} \; M'.z \; \overline{s}, \mt{con} \; x) &=& \mt{proj}(M', \overline{s'}, \mt{datatype} \; z) \textrm{ (where $\Gamma \vdash M' : \mt{sig} \; \overline{s'} \; \mt{end}$)} \\ + \\ + \mt{proj}(M, \mt{val} \; x : \tau \; \overline{s}, \mt{val} \; x) &=& \tau \\ + \mt{proj}(M, \mt{datatype} \; x \; \overline{y} = \overline{dc} \; \overline{s}, \mt{val} \; X) &=& \overline{y ::: \mt{Type}} \to M.x \; \overline y \textrm{ (where $X \in \overline{dc}$)} \\ + \mt{proj}(M, \mt{datatype} \; x \; \overline{y} = \overline{dc} \; \overline{s}, \mt{val} \; X) &=& \overline{y ::: \mt{Type}} \to \tau \to M.x \; \overline y \textrm{ (where $X \; \mt{of} \; \tau \in \overline{dc}$)} \\ + \mt{proj}(M, \mt{datatype} \; x = \mt{datatype} \; M'.z, \mt{val} \; X) &=& \overline{y ::: \mt{Type}} \to M.x \; \overline y \textrm{ (where $\Gamma \vdash M' : \mt{sig} \; \overline{s'} \; \mt{end}$} \\ + && \textrm{and $\mt{proj}(M', \overline{s'}, \mt{datatype} \; z = (\overline{y}, \overline{dc})$ and $X \in \overline{dc}$)} \\ + \mt{proj}(M, \mt{datatype} \; x = \mt{datatype} \; M'.z, \mt{val} \; X) &=& \overline{y ::: \mt{Type}} \to \tau \to M.x \; \overline y \textrm{ (where $\Gamma \vdash M' : \mt{sig} \; \overline{s'} \; \mt{end}$} \\ + && \textrm{and $\mt{proj}(M', \overline{s'}, \mt{datatype} \; z = (\overline{y}, \overline{dc})$ and $X : \tau \in \overline{dc}$)} \\ + \\ + \mt{proj}(M, \mt{structure} \; X : S \; \overline{s}, \mt{structure} \; X) &=& S \\ + \\ + \mt{proj}(M, \mt{signature} \; X = S \; \overline{s}, \mt{signature} \; X) &=& S \\ + \\ + \mt{proj}(M, \mt{con} \; x :: \kappa \; \overline{s}, V) &=& [x \mapsto M.x]\mt{proj}(M, \overline{s}, V) \\ + \mt{proj}(M, \mt{con} \; x :: \kappa = c \; \overline{s}, V) &=& [x \mapsto M.x]\mt{proj}(M, \overline{s}, V) \\ + \mt{proj}(M, \mt{datatype} \; x \; \overline{y} = \overline{dc} \; \overline{s}, V) &=& [x \mapsto M.x]\mt{proj}(M, \overline{s}, V) \\ + \mt{proj}(M, \mt{datatype} \; x = \mt{datatype} \; M'.z \; \overline{s}, V) &=& [x \mapsto M.x]\mt{proj}(M, \overline{s}, V) \\ + \mt{proj}(M, \mt{val} \; x : \tau \; \overline{s}, V) &=& \mt{proj}(M, \overline{s}, V) \\ + \mt{proj}(M, \mt{structure} \; X : S \; \overline{s}, V) &=& [X \mapsto M.X]\mt{proj}(M, \overline{s}, V) \\ + \mt{proj}(M, \mt{signature} \; X = S \; \overline{s}, V) &=& [X \mapsto M.X]\mt{proj}(M, \overline{s}, V) \\ + \mt{proj}(M, \mt{include} \; S \; \overline{s}, V) &=& \mt{proj}(M, \overline{s'} \; \overline{s}, V) \textrm{ (where $\Gamma \vdash S \equiv \mt{sig} \; \overline{s'} \; \mt{end}$)} \\ + \mt{proj}(M, \mt{constraint} \; c_1 \sim c_2 \; \overline{s}, V) &=& \mt{proj}(M, \overline{s}, V) \\ + \mt{proj}(M, \mt{class} \; x \; \overline{s}, V) &=& [x \mapsto M.x]\mt{proj}(M, \overline{s}, V) \\ + \mt{proj}(M, \mt{class} \; x = c \; \overline{s}, V) &=& [x \mapsto M.x]\mt{proj}(M, \overline{s}, V) \\ +\end{eqnarray*} + \end{document} \ No newline at end of file -- cgit v1.2.3 From 154fd594ccb664b07b27d63bd9ffee41801dd4d1 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 6 Dec 2008 12:01:12 -0500 Subject: Type inference --- doc/manual.tex | 40 ++++++++++++++++++++++++++++++++++++++-- 1 file changed, 38 insertions(+), 2 deletions(-) diff --git a/doc/manual.tex b/doc/manual.tex index 713bbe60..8ef6a889 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -358,7 +358,7 @@ $$\infer{\Gamma \vdash c \hookrightarrow \{c\}}{} \Gamma \vdash c \hookrightarrow C }$$ -\subsection{Definitional Equality} +\subsection{\label{definitional}Definitional Equality} We use $\mathcal C$ to stand for a one-hole context that, when filled, yields a constructor. The notation $\mathcal C[c]$ plugs $c$ into $\mathcal C$. We omit the standard definition of one-hole contexts. We write $[x \mapsto c_1]c_2$ for capture-avoiding substitution of $c_1$ for $x$ in $c_2$. @@ -530,7 +530,7 @@ $$\infer{\Gamma \vdash \{\overline{x = p}\} \leadsto \Gamma_n; \{\overline{x = \ We use an auxiliary judgment $\overline{y}; x; \Gamma \vdash \overline{dc} \leadsto \Gamma'$, expressing the enrichment of $\Gamma$ with the types of the datatype constructors $\overline{dc}$, when they are known to belong to datatype $x$ with type parameters $\overline{y}$. -This is the first judgment where we deal with type classes, for the $\mt{class}$ declaration form. We will omit their special handling in this formal specification. In the compiler, a set of available type classes and their instances is maintained, and these instances are used to fill in expression wildcards. +This is the first judgment where we deal with type classes, for the $\mt{class}$ declaration form. We will omit their special handling in this formal specification. Section \ref{typeclasses} gives an informal description of how type classes influence type inference. We presuppose the existence of a function $\mathcal O$, where $\mathcal(M, \overline{s})$ implements the $\mt{open}$ declaration by producing a context with the appropriate entry for each available component of module $M$ with signature items $\overline{s}$. Where possible, $\mathcal O$ uses ``transparent'' entries (e.g., an abstract type $M.x$ is mapped to $x :: \mt{Type} = M.x$), so that the relationship with $M$ is maintained. A related function $\mathcal O_c$ builds a context containing the disjointness constraints found in $S$. @@ -879,4 +879,40 @@ $$\infer{\Gamma \vdash M_1(M_2) : [X \mapsto M_2]S_2}{ \mt{proj}(M, \mt{class} \; x = c \; \overline{s}, V) &=& [x \mapsto M.x]\mt{proj}(M, \overline{s}, V) \\ \end{eqnarray*} + +\section{Type Inference} + +The Ur/Web compiler uses \emph{heuristic type inference}, with no claims of completeness with respect to the declarative specification of the last section. The rules in use seem to work well in practice. This section summarizes those rules, to help Ur programmers predict what will work and what won't. + +\subsection{Basic Unification} + +Type-checkers for languages based on the Hindly-Milner type discipline, like ML and Haskell, take advantage of \emph{principal typing} properties, making complete type inference relatively straightforward. Inference algorithms are traditionally implemented using type unification variables, at various points asserting equalities between types, in the process discovering the values of type variables. The Ur/Web compiler uses the same basic strategy, but the complexity of the type system rules out easy completeness. + +Type-checking can require evaluating recursive functional programs, thanks to the type-level $\mt{fold}$ operator. When a unification variable appears in such a type, the next step of computation can be undetermined. The value of that variable might be determined later, but this would be ``too late'' for the unification problems generated at the first occurrence. This is the essential source of incompletness. + +Nonetheless, the unification engine tends to do reasonably well. Unlike in ML, polymorphism is never inferred in definitions; it must be indicated explicitly by writing out constructor-level parameters. By writing these and other annotations, the programmer can generally get the type inference engine to do most of the type reconstruction work. + +\subsection{Unifying Record Types} + +The type inference engine tries to take advantage of the algebraic rules governing type-level records, as shown in Section \ref{definitional}. When two constructors of record kind are unified, they are reduce to normal forms, with like terms crossed off from each normal form until, hopefully, nothing remains. This cannot be complete, with the inclusion of unification variables. The type-checker can help you understand what goes wrong when the process fails, as it outputs the unmatched remainders of the two normal forms. + +\subsection{\label{typeclasses}Type Classes} + +Ur includes a type class facility inspired by Haskell's. The current version is very rudimentary, only supporting instances for particular types built up from abstract types and datatypes and type-level application. + +Type classes are integrated with the module system. A type class is just a constructor of kind $\mt{Type} \to \mt{Type}$. By marking such a constructor $c$ as a type class, the programmer instructs the type inference engine to, in each scope, record all values of types $c \; \tau$ as \emph{instances}. Any function argument whose type is of such a form is treated as implicit, to be determined by examining the current instance database. + +The ``dictionary encoding'' often used in Haskell implementations is made explicit in Ur. Type class instances are just properly-typed values, and they can also be considered as ``proofs'' of membership in the class. In some cases, it is useful to pass these proofs around explicitly. An underscore written where a proof is expected will also be inferred, if possible, from the current instance database. + +Just as for types, type classes may be exported from modules, and they may be exported as concrete or abstract. Concrete type classes have their ``real'' definitions exposed, so that client code may add new instances freely. Abstract type classes are useful as ``predicates'' that can be used to enforce invariants, as we will see in some definitions of SQL syntax in the Ur/Web standard library. + +\subsection{Reverse-Engineering Record Types} + +It's useful to write Ur functions and functors that take record constructors as inputs, but these constructors can grow quite long, even though their values are often implied by other arguments. The compiler uses a simple heuristic to infer the values of unification variables that are folded over, yielding known results. Often, as in the case of $\mt{map}$-like folds, the base and recursive cases of a fold produce constructors with different top-level structure. Thus, if the result of the fold is known, examining its top-level structure reveals whether the record being folded over is empty or not. If it's empty, we're done; if it's not empty, we replace a single unification variable with a new constructor formed from three new unification variables, as in $[\alpha = \beta] \rc \gamma$. This process can often be repeated to determine a unification variable fully. + +\subsection{Implicit Arguments in Functor Applications} + +Constructor, constraint, and type class witness members of structures may be omitted, when those structures are used in contexts where their assigned signatures imply how to fill in those missing members. This feature combines well with reverse-engineering to allow for uses of complicated meta-programming functors with little more code than would be necessary to invoke an untyped, ad-hoc code generator. + + \end{document} \ No newline at end of file -- cgit v1.2.3 From 718a8e9fc7cd60f227f56e6031c7e9ac054cb488 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 6 Dec 2008 13:04:48 -0500 Subject: Start of Ur/Web library --- doc/manual.tex | 47 +++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 47 insertions(+) diff --git a/doc/manual.tex b/doc/manual.tex index 8ef6a889..894287e1 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -915,4 +915,51 @@ It's useful to write Ur functions and functors that take record constructors as Constructor, constraint, and type class witness members of structures may be omitted, when those structures are used in contexts where their assigned signatures imply how to fill in those missing members. This feature combines well with reverse-engineering to allow for uses of complicated meta-programming functors with little more code than would be necessary to invoke an untyped, ad-hoc code generator. +\section{The Ur Standard Library} + +The built-in parts of the Ur/Web standard library are described by the signature in \texttt{lib/basis.urs} in the distribution. A module $\mt{Basis}$ ascribing to that signature is available in the initial environment, and every program is implicitly prefixed by $\mt{open} \; \mt{Basis}$. + +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} \\ + \mt{type} \; \mt{string} \\ + \mt{type} \; \mt{time} \\ + \\ + \mt{type} \; \mt{unit} = \{\} \\ + \\ + \mt{datatype} \; \mt{bool} = \mt{False} \mid \mt{True} \\ + \\ + \mt{datatype} \; \mt{option} \; \mt{t} = \mt{None} \mid \mt{Some} \; \mt{of} \; \mt{t} +\end{array}$$ + + +\section{The Ur/Web Standard Library} + +\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} \\ + \\ + \mt{val} \; \mt{return} : \mt{t} ::: \mt{Type} \to \mt{t} \to \mt{transaction} \; \mt{t} \\ + \mt{val} \; \mt{bind} : \mt{t_1} ::: \mt{Type} \to \mt{t_2} ::: \mt{Type} \to \mt{transaction} \; \mt{t_1} \to (\mt{t_1} \to \mt{transaction} \; \mt{t_2}) \to \mt{transaction} \; \mt{t_2} +\end{array}$$ + +\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}) \\ +\\ +\mt{con} \; \mt{http\_cookie} :: \mt{Type} \to \mt{Type} \\ +\mt{val} \; \mt{getCookie} : \mt{t} ::: \mt{Type} \to \mt{http\_cookie} \; \mt{t} \to \mt{transaction} \; (\mt{option} \; \mt{t}) \\ +\mt{val} \; \mt{setCookie} : \mt{t} ::: \mt{Type} \to \mt{http\_cookie} \; \mt{t} \to \mt{t} \to \mt{transaction} \; \mt{unit} +\end{array}$$ + \end{document} \ No newline at end of file -- cgit v1.2.3 From 80bbc587e8c3e897cb30f0723187950254c6632b Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 7 Dec 2008 09:19:53 -0500 Subject: Start of sql_exp --- doc/manual.tex | 85 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 85 insertions(+) diff --git a/doc/manual.tex b/doc/manual.tex index 894287e1..0a0bdc88 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -962,4 +962,89 @@ $$\begin{array}{l} \mt{val} \; \mt{setCookie} : \mt{t} ::: \mt{Type} \to \mt{http\_cookie} \; \mt{t} \to \mt{t} \to \mt{transaction} \; \mt{unit} \end{array}$$ +\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}$$ + +\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}\}\} \\ + \hspace{.1in} \to \mt{selectedFields} ::: \{\{\mt{Type}\}\} \\ + \hspace{.1in} \to \mt{selectedExps} ::: \{\mt{Type}\} \\ + \hspace{.1in} \to \{\mt{Rows} : \mt{sql\_query1} \; \mt{tables} \; \mt{selectedFields} \; \mt{selectedExps}, \\ + \hspace{.2in} \mt{OrderBy} : \mt{sql\_order\_by} \; \mt{tables} \; \mt{selectedExps}, \\ + \hspace{.2in} \mt{Limit} : \mt{sql\_limit}, \\ + \hspace{.2in} \mt{Offset} : \mt{sql\_offset}\} \\ + \hspace{.1in} \to \mt{sql\_query} \; \mt{selectedFields} \; \mt{selectedExps} +\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} \\ + \\ + \mt{type} \; \mt{sql\_relop} \\ + \mt{val} \; \mt{sql\_union} : \mt{sql\_relop} \\ + \mt{val} \; \mt{sql\_intersect} : \mt{sql\_relop} \\ + \mt{val} \; \mt{sql\_except} : \mt{sql\_relop} \\ + \mt{val} \; \mt{sql\_relop} : \mt{tables1} ::: \{\{\mt{Type}\}\} \\ + \hspace{.1in} \to \mt{tables2} ::: \{\{\mt{Type}\}\} \\ + \hspace{.1in} \to \mt{selectedFields} ::: \{\{\mt{Type}\}\} \\ + \hspace{.1in} \to \mt{selectedExps} ::: \{\mt{Type}\} \\ + \hspace{.1in} \to \mt{sql\_relop} \\ + \hspace{.1in} \to \mt{sql\_query1} \; \mt{tables1} \; \mt{selectedFields} \; \mt{selectedExps} \\ + \hspace{.1in} \to \mt{sql\_query1} \; \mt{tables2} \; \mt{selectedFields} \; \mt{selectedExps} \\ + \hspace{.1in} \to \mt{sql\_query1} \; \mt{selectedFields} \; \mt{selectedFields} \; \mt{selectedExps} +\end{array}$$ + +$$\begin{array}{l} + \mt{val} \; \mt{sql\_query1} : \mt{tables} ::: \{\{\mt{Type}\}\} \\ + \hspace{.1in} \to \mt{grouped} ::: \{\{\mt{Type}\}\} \\ + \hspace{.1in} \to \mt{selectedFields} ::: \{\{\mt{Type}\}\} \\ + \hspace{.1in} \to \mt{selectedExps} ::: \{\mt{Type}\} \\ + \hspace{.1in} \to \{\mt{From} : \$(\mt{fold} \; (\lambda \mt{nm} \; (\mt{fields} :: \{\mt{Type}\}) \; \mt{acc} \; [[\mt{nm}] \sim \mt{acc}] \Rightarrow [\mt{nm} = \mt{sql\_table} \; \mt{fields}] \rc \mt{acc}) \; [] \; \mt{tables}), \\ + \hspace{.2in} \mt{Where} : \mt{sql\_exp} \; \mt{tables} \; [] \; [] \; \mt{bool}, \\ + \hspace{.2in} \mt{GroupBy} : \mt{sql\_subset} \; \mt{tables} \; \mt{grouped}, \\ + \hspace{.2in} \mt{Having} : \mt{sql\_exp} \; \mt{grouped} \; \mt{tables} \; [] \; \mt{bool}, \\ + \hspace{.2in} \mt{SelectFields} : \mt{sql\_subset} \; \mt{grouped} \; \mt{selectedFields}, \\ + \hspace{.2in} \mt {SelectExps} : \$(\mt{fold} \; (\lambda \mt{nm} \; (\mt{t} :: \mt{Type}) \; \mt{acc} \; [[\mt{nm}] \sim \mt{acc}] \Rightarrow [\mt{nm} = \mt{sql\_exp} \; \mt{grouped} \; \mt{tables} \; [] \; \mt{t}] \rc \mt{acc}) \; [] \; \mt{selectedExps}) \} \\ + \hspace{.1in} \to \mt{sql\_query1} \; \mt{tables} \; \mt{selectedFields} \; \mt{selectedExps} +\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}\})\} \\ + \hspace{.1in} \to \mt{sql\_subset} \\ + \hspace{.2in} (\mt{fold} \; (\lambda \mt{nm} \; (\mt{fields} :: (\{\mt{Type}\} \times \{\mt{Type}\})) \; \mt{acc} \; [[\mt{nm}] \sim \mt{acc}] \; [\mt{fields}.1 \sim \mt{fields}.2] \Rightarrow \\ + \hspace{.3in} [\mt{nm} = \mt{fields}.1 \rc \mt{fields}.2] \rc \mt{acc}) \; [] \; \mt{keep\_drop}) \\ + \hspace{.2in} (\mt{fold} \; (\lambda \mt{nm} \; (\mt{fields} :: (\{\mt{Type}\} \times \{\mt{Type}\})) \; \mt{acc} \; [[\mt{nm}] \sim \mt{acc}] \Rightarrow [\mt{nm} = \mt{fields}.1] \rc \mt{acc}) \; [] \; \mt{keep\_drop}) \\ +\mt{val} \; \mt{sql\_subset\_all} : \mt{tables} :: \{\{\mt{Type}\}\} \to \mt{sql\_subset} \; \mt{tables} \; \mt{tables} +\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}\}\} \\ + \hspace{.1in} \to \mt{exps} ::: \{\mt{Type}\} \\ + \hspace{.1in} \to \mt{tab} :: \mt{Name} \to \mt{field} :: \mt{Name} \\ + \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}$$ + \end{document} \ No newline at end of file -- 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(-) 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 d86935ec25586bbba5b6aaf60fb93d20e99de964 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 7 Dec 2008 10:24:23 -0500 Subject: DML --- doc/manual.tex | 36 ++++++++++++++++++++++++++++++++++++ 1 file changed, 36 insertions(+) diff --git a/doc/manual.tex b/doc/manual.tex index fb6b3b01..83ce8867 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -981,6 +981,14 @@ $$\begin{array}{l} \hspace{.1in} \to \mt{sql\_query} \; \mt{selectedFields} \; \mt{selectedExps} \end{array}$$ +Queries are used by folding over their results inside transactions. +$$\begin{array}{l} + \mt{val} \; \mt{query} : \mt{tables} ::: \{\{\mt{Type}\}\} \to \mt{exps} ::: \{\mt{Type}\} \to \lambda [\mt{tables} \sim \mt{exps}] \Rightarrow \mt{state} ::: \mt{Type} \to \mt{sql\_query} \; \mt{tables} \; \mt{exps} \\ + \hspace{.1in} \to (\$(\mt{exps} \rc \mt{fold} \; (\lambda \mt{nm} \; (\mt{fields} :: \{\mt{Type}\}) \; \mt{acc} \; [[\mt{nm}] \sim \mt{acc}] \Rightarrow [\mt{nm} = \$\mt{fields}] \rc \mt{acc}) \; [] \; \mt{tables}) \\ + \hspace{.2in} \to \mt{state} \to \mt{transaction} \; \mt{state}) \\ + \hspace{.1in} \to \mt{state} \to \mt{transaction} \; \mt{state} +\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} \\ @@ -1151,4 +1159,32 @@ $$\begin{array}{l} \mt{val} \; \mt{sql\_offset} : \mt{int} \to \mt{sql\_offset} \end{array}$$ + +\subsubsection{DML} + +The Ur/Web library also includes an embedding of a fragment of SQL's DML, the Data Manipulation Language, for modifying database tables. Any piece of DML may be executed in a transaction. + +$$\begin{array}{l} + \mt{type} \; \mt{dml} \\ + \mt{val} \; \mt{dml} : \mt{dml} \to \mt{transaction} \; \mt{unit} +\end{array}$$ + +Properly-typed records may be used to form $\mt{INSERT}$ commands. +$$\begin{array}{l} + \mt{val} \; \mt{insert} : \mt{fields} ::: \{\mt{Type}\} \to \mt{sql\_table} \; \mt{fields} \\ + \hspace{.1in} \to \$(\mt{fold} \; (\lambda \mt{nm} \; (\mt{t} :: \mt{Type}) \; \mt{acc} \; [[\mt{nm}] \sim \mt{acc}] \Rightarrow [\mt{nm} = \mt{sql\_exp} \; [] \; [] \; [] \; \mt{t}] \rc \mt{acc}) \; [] \; \mt{fields}) \to \mt{dml} +\end{array}$$ + +An $\mt{UPDATE}$ command is formed from a choice of which table fields to leave alone and which to change, along with an expression to use to compute the new value of each changed field and a $\mt{WHERE}$ clause. +$$\begin{array}{l} + \mt{val} \; \mt{update} : \mt{unchanged} ::: \{\mt{Type}\} \to \mt{changed} :: \{\mt{Type}\} \to \lambda [\mt{changed} \sim \mt{unchanged}] \\ + \hspace{.1in} \Rightarrow \$(\mt{fold} \; (\lambda \mt{nm} \; (\mt{t} :: \mt{Type}) \; \mt{acc} \; [[\mt{nm}] \sim \mt{acc}] \Rightarrow [\mt{nm} = \mt{sql\_exp} \; [\mt{T} = \mt{changed} \rc \mt{unchanged}] \; [] \; [] \; \mt{t}] \rc \mt{acc}) \; [] \; \mt{changed}) \\ + \hspace{.1in} \to \mt{sql\_table} \; (\mt{changed} \rc \mt{unchanged}) \to \mt{sql\_exp} \; [\mt{T} = \mt{changed} \rc \mt{unchanged}] \; [] \; [] \; \mt{bool} \to \mt{dml} +\end{array}$$ + +A $\mt{DELETE}$ command is formed from a table and a $\mt{WHERE}$ clause. +$$\begin{array}{l} + \mt{val} \; \mt{delete} : \mt{fields} ::: \{\mt{Type}\} \to \mt{sql\_table} \; \mt{fields} \to \mt{sql\_exp} \; [\mt{T} = \mt{fields}] \; [] \; [] \; \mt{bool} \to \mt{dml} +\end{array}$$ + \end{document} \ No newline at end of file -- cgit v1.2.3 From 41c63800f3c6f330002b29b133836f6e4f7a81d3 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 7 Dec 2008 10:25:55 -0500 Subject: Sequences --- doc/manual.tex | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/doc/manual.tex b/doc/manual.tex index 83ce8867..95d2d548 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -1187,4 +1187,14 @@ $$\begin{array}{l} \mt{val} \; \mt{delete} : \mt{fields} ::: \{\mt{Type}\} \to \mt{sql\_table} \; \mt{fields} \to \mt{sql\_exp} \; [\mt{T} = \mt{fields}] \; [] \; [] \; \mt{bool} \to \mt{dml} \end{array}$$ +\subsubsection{Sequences} + +SQL sequences are counters with concurrency control, often used to assign unique IDs. Ur/Web supports them via a simple interface. The only way to create a sequence is with the $\mt{sequence}$ declaration form. + +$$\begin{array}{l} + \mt{type} \; \mt{sql\_sequence} \\ + \mt{val} \; \mt{nextval} : \mt{sql\_sequence} \to \mt{transaction} \; \mt{int} +\end{array}$$ + + \end{document} \ No newline at end of file -- cgit v1.2.3 From fe138022197bc0dede592fc1df97e1ef540c1b6a Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 7 Dec 2008 10:59:14 -0500 Subject: XML --- doc/manual.tex | 48 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/doc/manual.tex b/doc/manual.tex index 95d2d548..0dc33a4d 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -1197,4 +1197,52 @@ $$\begin{array}{l} \end{array}$$ +\subsection{XML} + +Ur/Web's library contains an encoding of XML syntax and semantic constraints. We make no effort to follow the standards governing XML schemas. Rather, XML fragments are viewed more as values of ML datatypes, and we only track which tags are allowed inside which other tags. + +The basic XML type family has arguments respectively indicating the \emph{context} of a fragment, the fields that the fragment expects to be bound on entry (and their types), and the fields that the fragment will bind (and their types). Contexts are a record-based ``poor man's subtyping'' encoding, with each possible set of valid tags corresponding to a different context record. The arguments dealing with field binding are only relevant to HTML forms. +$$\begin{array}{l} + \mt{con} \; \mt{xml} :: \{\mt{Unit}\} \to \{\mt{Type}\} \to \{\mt{Type}\} \to \mt{Type} +\end{array}$$ + +We also have a type family of XML tags, indexed respectively by the record of optional attributes accepted by the tag, the context in which the tag may be placed, the context required of children of the tag, which form fields the tag uses, and which fields the tag defines. +$$\begin{array}{l} + \mt{con} \; \mt{tag} :: \{\mt{Type}\} \to \{\mt{Unit}\} \to \{\mt{Unit}\} \to \{\mt{Type}\} \to \{\mt{Type}\} \to \mt{Type} +\end{array}$$ + +Literal text may be injected into XML as ``CDATA.'' +$$\begin{array}{l} + \mt{val} \; \mt{cdata} : \mt{ctx} ::: \{\mt{Unit}\} \to \mt{use} ::: \{\mt{Type}\} \to \mt{string} \to \mt{xml} \; \mt{ctx} \; \mt{use} \; [] +\end{array}$$ + +There is a function for producing an XML tree with a particular tag at its root. +$$\begin{array}{l} + \mt{val} \; \mt{tag} : \mt{attrsGiven} ::: \{\mt{Type}\} \to \mt{attrsAbsent} ::: \{\mt{Type}\} \to \mt{ctxOuter} ::: \{\mt{Unit}\} \to \mt{ctxInner} ::: \{\mt{Unit}\} \\ + \hspace{.1in} \to \mt{useOuter} ::: \{\mt{Type}\} \to \mt{useInner} ::: \{\mt{Type}\} \to \mt{bindOuter} ::: \{\mt{Type}\} \to \mt{bindInner} ::: \{\mt{Type}\} \\ + \hspace{.1in} \to \lambda [\mt{attrsGiven} \sim \mt{attrsAbsent}] \; [\mt{useOuter} \sim \mt{useInner}] \; [\mt{bindOuter} \sim \mt{bindInner}] \Rightarrow \$\mt{attrsGiven} \\ + \hspace{.1in} \to \mt{tag} \; (\mt{attrsGiven} \rc \mt{attrsAbsent}) \; \mt{ctxOuter} \; \mt{ctxInner} \; \mt{useOuter} \; \mt{bindOuter} \\ + \hspace{.1in} \to \mt{xml} \; \mt{ctxInner} \; \mt{useInner} \; \mt{bindInner} \to \mt{xml} \; \mt{ctxOuter} \; (\mt{useOuter} \rc \mt{useInner}) \; (\mt{bindOuter} \rc \mt{bindInner}) +\end{array}$$ + +Two XML fragments may be concatenated. +$$\begin{array}{l} + \mt{val} \; \mt{join} : \mt{ctx} ::: \{\mt{Unit}\} \to \mt{use_1} ::: \{\mt{Type}\} \to \mt{bind_1} ::: \{\mt{Type}\} \to \mt{bind_2} ::: \{\mt{Type}\} \\ + \hspace{.1in} \to \lambda [\mt{use_1} \sim \mt{bind_1}] \; [\mt{bind_1} \sim \mt{bind_2}] \\ + \hspace{.1in} \Rightarrow \mt{xml} \; \mt{ctx} \; \mt{use_1} \; \mt{bind_1} \to \mt{xml} \; \mt{ctx} \; (\mt{use_1} \rc \mt{bind_1}) \; \mt{bind_2} \to \mt{xml} \; \mt{ctx} \; \mt{use_1} \; (\mt{bind_1} \rc \mt{bind_2}) +\end{array}$$ + +Finally, any XML fragment may be updated to ``claim'' to use more form fields than it does. +$$\begin{array}{l} + \mt{val} \; \mt{useMore} : \mt{ctx} ::: \{\mt{Unit}\} \to \mt{use_1} ::: \{\mt{Type}\} \to \mt{use_2} ::: \{\mt{Type}\} \to \mt{bind} ::: \{\mt{Type}\} \to \lambda [\mt{use_1} \sim \mt{use_2}] \\ + \hspace{.1in} \Rightarrow \mt{xml} \; \mt{ctx} \; \mt{use_1} \; \mt{bind} \to \mt{xml} \; \mt{ctx} \; (\mt{use_1} \rc \mt{use_2}) \; \mt{bind} +\end{array}$$ + +We will not list here the different HTML tags and related functions from the standard library. They should be easy enough to understand from the code in \texttt{basis.urs}. The set of tags in the library is not yet claimed to be complete for HTML standards. + +One last useful function is for aborting any page generation, returning some XML as an error message. This function takes the place of some uses of a general exception mechanism. +$$\begin{array}{l} + \mt{val} \; \mt{error} : \mt{t} ::: \mt{Type} \to \mt{xml} \; [\mt{Body}] \; [] \; [] \to \mt{t} +\end{array}$$ + \end{document} \ No newline at end of file -- cgit v1.2.3 From a63d958e6836e1240d27fdbf64cb7cd2bbee65cf Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 7 Dec 2008 11:19:13 -0500 Subject: Treat user-provided error messages as XML --- src/c/driver.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/c/driver.c b/src/c/driver.c index a9a5ce3f..df154aea 100644 --- a/src/c/driver.c +++ b/src/c/driver.c @@ -255,10 +255,11 @@ static void *worker(void *data) { uw_reset_keep_error_message(ctx); uw_write_header(ctx, "HTTP/1.1 500 Internal Server Error\r\n"); - uw_write_header(ctx, "Content-type: text/plain\r\n"); + uw_write_header(ctx, "Content-type: text/html\r\n"); + uw_write(ctx, "Fatal Error"); uw_write(ctx, "Fatal error: "); uw_write(ctx, uw_error_message(ctx)); - uw_write(ctx, "\n"); + uw_write(ctx, "\n"); try_rollback(ctx); -- cgit v1.2.3 From b45bf9b187a61b2a803555025e1d6496144a9759 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 7 Dec 2008 12:02:54 -0500 Subject: Query syntax --- doc/manual.tex | 54 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 54 insertions(+) diff --git a/doc/manual.tex b/doc/manual.tex index 0dc33a4d..79cda554 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -1245,4 +1245,58 @@ $$\begin{array}{l} \mt{val} \; \mt{error} : \mt{t} ::: \mt{Type} \to \mt{xml} \; [\mt{Body}] \; [] \; [] \to \mt{t} \end{array}$$ + +\section{Ur/Web Syntax Extensions} + +Ur/Web features some syntactic shorthands for building values using the functions from the last section. This section sketches the grammar of those extensions. We write spans of syntax inside brackets to indicate that they are optional. + +\subsection{SQL} + +\subsubsection{Queries} + +$$\begin{array}{rrcll} + \textrm{Queries} & Q &::=& (q \; [\mt{ORDER} \; \mt{BY} \; (E \; [D],)^+] \; [\mt{LIMIT} \; N] \; [\mt{OFFSET} \; N]) \\ + \textrm{Pre-queries} & q &::=& \mt{SELECT} \; P \; \mt{FROM} \; T,^+ \; [\mt{WHERE} \; E] \; [\mt{GROUP} \; \mt{BY} \; p,^+] \; [\mt{HAVING} \; E] \\ + &&& \mid q \; R \; q \\ + \textrm{Relational operators} & R &::=& \mt{UNION} \mid \mt{INTERSECT} \mid \mt{EXCEPT} +\end{array}$$ + +$$\begin{array}{rrcll} + \textrm{Projections} & P &::=& \ast & \textrm{all columns} \\ + &&& p,^+ & \textrm{particular columns} \\ + \textrm{Pre-projections} & p &::=& t.f & \textrm{one column from a table} \\ + &&& t.\{\{c\}\} & \textrm{a record of colums from a table (of kind $\{\mt{Type}\}$)} \\ + \textrm{Table names} & t &::=& x & \textrm{constant table name (automatically capitalized)} \\ + &&& X & \textrm{constant table name} \\ + &&& \{\{c\}\} & \textrm{computed table name (of kind $\mt{Name}$)} \\ + \textrm{Column names} & f &::=& X & \textrm{constant column name} \\ + &&& \{c\} & \textrm{computed column name (of kind $\mt{Name}$)} \\ + \textrm{Tables} & T &::=& x & \textrm{table variable, named locally by its own capitalization} \\ + &&& x \; \mt{AS} \; t & \textrm{table variable, with local name} \\ + &&& \{\{e\}\} \; \mt{AS} \; t & \textrm{computed table expression, with local name} \\ + \textrm{SQL expressions} & E &::=& p & \textrm{column references} \\ + &&& X & \textrm{named expression references} \\ + &&& \{\{e\}\} & \textrm{injected native Ur expressions} \\ + &&& \{e\} & \textrm{computed expressions, probably using $\mt{sql\_exp}$ directly} \\ + &&& \mt{TRUE} \mid \mt{FALSE} & \textrm{boolean constants} \\ + &&& \ell & \textrm{primitive type literals} \\ + &&& \mt{NULL} & \textrm{null value (injection of $\mt{None}$)} \\ + &&& E \; \mt{IS} \; \mt{NULL} & \textrm{nullness test} \\ + &&& n & \textrm{nullary operators} \\ + &&& u \; E & \textrm{unary operators} \\ + &&& E \; b \; E & \textrm{binary operators} \\ + &&& \mt{COUNT}(\ast) & \textrm{count number of rows} \\ + &&& a(E) & \textrm{other aggregate function} \\ + &&& (E) & \textrm{explicit precedence} \\ + \textrm{Nullary operators} & n &::=& \mt{CURRENT\_TIMESTAMP} \\ + \textrm{Unary operators} & u &::=& \mt{NOT} \\ + \textrm{Binary operators} & b &::=& \mt{AND} \mid \mt{OR} \mid \neq \mid < \mid \leq \mid > \mid \geq \\ + \textrm{Aggregate functions} & a &::=& \mt{AVG} \mid \mt{SUM} \mid \mt{MIN} \mid \mt{MAX} \\ + \textrm{Directions} & D &::=& \mt{ASC} \mid \mt{DESC} \\ + \textrm{SQL integer} & N &::=& n \mid \{e\} \\ +\end{array}$$ + +Additionally, an SQL expression may be inserted into normal Ur code with the syntax $(\mt{SQL} \; E)$ or $(\mt{WHERE} \; E)$. + + \end{document} \ No newline at end of file -- cgit v1.2.3 From 4532add1a287aa8922ba5d0d556db3cd04e42420 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 7 Dec 2008 12:10:51 -0500 Subject: DML --- doc/manual.tex | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/doc/manual.tex b/doc/manual.tex index 79cda554..4915edfb 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -1254,8 +1254,10 @@ Ur/Web features some syntactic shorthands for building values using the function \subsubsection{Queries} +Queries $Q$ are added to the rules for expressions $e$. + $$\begin{array}{rrcll} - \textrm{Queries} & Q &::=& (q \; [\mt{ORDER} \; \mt{BY} \; (E \; [D],)^+] \; [\mt{LIMIT} \; N] \; [\mt{OFFSET} \; N]) \\ + \textrm{Queries} & Q &::=& (q \; [\mt{ORDER} \; \mt{BY} \; (E \; [o],)^+] \; [\mt{LIMIT} \; N] \; [\mt{OFFSET} \; N]) \\ \textrm{Pre-queries} & q &::=& \mt{SELECT} \; P \; \mt{FROM} \; T,^+ \; [\mt{WHERE} \; E] \; [\mt{GROUP} \; \mt{BY} \; p,^+] \; [\mt{HAVING} \; E] \\ &&& \mid q \; R \; q \\ \textrm{Relational operators} & R &::=& \mt{UNION} \mid \mt{INTERSECT} \mid \mt{EXCEPT} @@ -1292,11 +1294,23 @@ $$\begin{array}{rrcll} \textrm{Unary operators} & u &::=& \mt{NOT} \\ \textrm{Binary operators} & b &::=& \mt{AND} \mid \mt{OR} \mid \neq \mid < \mid \leq \mid > \mid \geq \\ \textrm{Aggregate functions} & a &::=& \mt{AVG} \mid \mt{SUM} \mid \mt{MIN} \mid \mt{MAX} \\ - \textrm{Directions} & D &::=& \mt{ASC} \mid \mt{DESC} \\ + \textrm{Directions} & o &::=& \mt{ASC} \mid \mt{DESC} \\ \textrm{SQL integer} & N &::=& n \mid \{e\} \\ \end{array}$$ Additionally, an SQL expression may be inserted into normal Ur code with the syntax $(\mt{SQL} \; E)$ or $(\mt{WHERE} \; E)$. +\subsubsection{DML} + +DML commands $D$ are added to the rules for expressions $e$. + +$$\begin{array}{rrcll} + \textrm{Commands} & D &::=& (\mt{INSERT} \; \mt{INTO} \; T^E \; (f,^+) \; \mt{VALUES} \; (E,^+)) \\ + &&& (\mt{UPDATE} \; T^E \; \mt{SET} \; (f = E,)^+ \; \mt{WHERE} \; E) \\ + &&& (\mt{DELETE} \; \mt{FROM} \; T^E \; \mt{WHERE} \; E) \\ + \textrm{Table expressions} & T^E &::=& x \mid \{\{e\}\} +\end{array}$$ + +Inside $\mt{UPDATE}$ and $\mt{DELETE}$ commands, lone variables $X$ are interpreted as references to columns of the implicit table $\mt{T}$, rather than to named expressions. \end{document} \ No newline at end of file -- cgit v1.2.3 From 13eec52acec99c062f98a80b38c590ad7adfd8b9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 7 Dec 2008 12:21:47 -0500 Subject: XML syntax --- doc/manual.tex | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/doc/manual.tex b/doc/manual.tex index 4915edfb..b52146de 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -1313,4 +1313,20 @@ $$\begin{array}{rrcll} Inside $\mt{UPDATE}$ and $\mt{DELETE}$ commands, lone variables $X$ are interpreted as references to columns of the implicit table $\mt{T}$, rather than to named expressions. +\subsection{XML} + +XML fragments $L$ are added to the rules for expressions $e$. + +$$\begin{array}{rrcll} + \textrm{XML fragments} & L &::=& \texttt{} \mid \texttt{}l^*\texttt{} \\ + \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} \\ + \textrm{Tag} & g &::=& h \; (x = v)^* \\ + \textrm{Tag head} & h &::=& x & \textrm{tag name} \\ + &&& h\{c\} & \textrm{constructor parameter} \\ + \textrm{Attribute value} & v &::=& \ell & \textrm{literal value} \\ + &&& \{e\} & \textrm{computed value} \\ +\end{array}$$ + \end{document} \ No newline at end of file -- cgit v1.2.3 From da893776fddf8136a4b8ae6cfcb536e0fe6863ca Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 7 Dec 2008 14:50:03 -0500 Subject: Compiler phases --- doc/manual.tex | 99 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 98 insertions(+), 1 deletion(-) diff --git a/doc/manual.tex b/doc/manual.tex index b52146de..12939a56 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -47,7 +47,7 @@ We write $\ell$ for literals of the primitive types, for the most part following This version of the manual doesn't include operator precedences; see \texttt{src/urweb.grm} for that. -\subsection{Core Syntax} +\subsection{\label{core}Core Syntax} \emph{Kinds} classify types and other compile-time-only entities. Each kind in the grammar is listed with a description of the sort of data it classifies. $$\begin{array}{rrcll} @@ -1329,4 +1329,101 @@ $$\begin{array}{rrcll} &&& \{e\} & \textrm{computed value} \\ \end{array}$$ + +\section{Compiler Phases} + +The Ur/Web compiler is unconventional in that it relies on a kind of \emph{heuristic compilation}. Not all valid programs will compile successfully. Informally, programs fail to compile when they are ``too higher order.'' Compiler phases do their best to eliminate different kinds of higher order-ness, but some programs just won't compile. This is a trade-off for producing very efficient executables. Compiled Ur/Web programs use native C representations and require no garbage collection. + +In this section, we step through the main phases of compilation, noting what consequences each phase has for effective programming. + +\subsection{Parse} + +The compiler reads a \texttt{.urp} file, figures out which \texttt{.urs} and \texttt{.ur} files it references, and combines them all into what is conceptually a single sequence of declarations in the core language of Section \ref{core}. + +\subsection{Elaborate} + +This is where type inference takes place, translating programs into an explicit form with no more wildcards. This phase is the most likely source of compiler error messages. + +\subsection{Unnest} + +Named local function definitions are moved to the top level, to avoid the need to generate closures. + +\subsection{Corify} + +Module system features are compiled away, through inlining of functor definitions at application sites. Afterward, most abstraction boundaries are broken, facilitating optimization. + +\subsection{Especialize} + +Functions are specialized to particular argument patterns. This is an important trick for avoiding the need to maintain any closures at runtime. + +\subsection{Untangle} + +Remove unnecessary mutual recursion, splitting recursive groups into strongly-connected components. + +\subsection{Shake} + +Remove all definitions not needed to run the page handlers that are visible in the signature of the last module listed in the \texttt{.urp} file. + +\subsection{Tag} + +Assign a URL name to each link and form action. It is important that these links and actions are written as applications of named functions, because such names are used to generate URL patterns. A URL pattern has a name built from the full module path of the named function, followed by the function name, with all pieces separated by slashes. The path of a functor application is based on the name given to the result, rather than the path of the functor itself. + +\subsection{Reduce} + +Apply definitional equality rules to simplify the program as much as possible. This effectively includes inlining of every non-recursive definition. + +\subsection{Unpoly} + +This phase specializes polymorphic functions to the specific arguments passed to them in the program. If the program contains real polymorphic recursion, Unpoly will be insufficient to avoid later error messages about too much polymorphism. + +\subsection{Specialize} + +Replace uses of parametrized datatypes with versions specialized to specific parameters. As for Unpoly, this phase will not be effective enough in the presence of polymorphic recursion or other fancy uses of impredicative polymorphism. + +\subsection{Shake} + +Here the compiler repeats the earlier shake phase. + +\subsection{Monoize} + +Programs are translated to a new intermediate language without polymorphism or non-$\mt{Type}$ constructors. Error messages may pop up here if earlier phases failed to remove such features. + +This is the stage at which concrete names are generated for cookies, tables, and sequences. They are named following the same convention as for links and actions, based on module path information saved from earlier stages. Table and sequence names separate path elements with underscores instead of slashes, and they are prefixed by \texttt{uw\_}. +\subsection{MonoOpt} + +Simple algebraic laws are applied to simplify the program, focusing especially on efficient imperative generation of HTML pages. + +\subsection{MonoUntangle} + +Unnecessary mutual recursion is broken up again. + +\subsection{MonoReduce} + +Equivalents of the definitional equality rules are applied to simplify programs, with inlining again playing a major role. + +\subsection{MonoShake, MonoOpt} + +Unneeded declarations are removed, and basic optimizations are repeated. + +\subsection{Fuse} + +The compiler tries to simplify calls to recursive functions whose results are immediately written as page output. The write action is pushed inside the function definitions to avoid allocation of intermediate results. + +\subsection{MonoUntangle, MonoShake} + +Fuse often creates more opportunities to remove spurious mutual recursion. + +\subsection{Pathcheck} + +The compiler checks that no link or action name has been used more than once. + +\subsection{Cjrize} + +The program is translated to what is more or less a subset of C. If any use of functions as data remains at this point, the compiler will complain. + +\subsection{C Compilation and Linking} + +The output of the last phase is pretty-printed as C source code and passed to GCC. + + \end{document} \ No newline at end of file -- cgit v1.2.3 From ca1b68736e14dff52c08e76a7a6dfa855d1884f9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 7 Dec 2008 15:01:21 -0500 Subject: The structure of web applications --- doc/manual.tex | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/doc/manual.tex b/doc/manual.tex index 12939a56..46404f7c 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -1330,6 +1330,17 @@ $$\begin{array}{rrcll} \end{array}$$ +\section{The Structure of Web Applications} + +A web application is built from a series of modules, with one module, the last one appearing in the \texttt{.urp} file, designated as the main module. The signature of the main module determines the URL entry points to the application. Such an entry point should have type $\mt{unit} \to \mt{transaction} \; \mt{page}$, where $\mt{page}$ is a type synonym for top-level HTML pages, defined in $\mt{Basis}$. If such a function is at the top level of main module $M$, it will be accessible at URI \texttt{/M/f}, and so on for more deeply-nested functions, as described in Section \ref{tag} below. + +When the standalone web server receives a request for a known page, it calls the function for that page, ``running'' the resulting transaction to produce the page to return to the client. Pages link to other pages with the \texttt{link} attribute of the \texttt{a} HTML tag. A link has type $\mt{transaction} \; \mt{page}$, and the semantics of a link are that this transaction should be run to compute the result page, when the link is followed. Link targets are assigned URL names in the same way as top-level entry points. + +HTML forms are handled in a similar way. The $\mt{action}$ attribute of a $\mt{submit}$ form tag takes a value of type $\$\mt{use} \to \mt{transaction} \; \mt{page}$, where $\mt{use}$ is a kind-$\{\mt{Type}\}$ record of the form fields used by this action handler. Action handlers are assigned URL patterns in the same way as above. + +For both links and actions, direct arguments and local variables mentioned implicitly via closures are automatically included in serialized form in URLs, in the order in which they appeared in the source code. + + \section{Compiler Phases} The Ur/Web compiler is unconventional in that it relies on a kind of \emph{heuristic compilation}. Not all valid programs will compile successfully. Informally, programs fail to compile when they are ``too higher order.'' Compiler phases do their best to eliminate different kinds of higher order-ness, but some programs just won't compile. This is a trade-off for producing very efficient executables. Compiled Ur/Web programs use native C representations and require no garbage collection. @@ -1364,7 +1375,7 @@ Remove unnecessary mutual recursion, splitting recursive groups into strongly-co Remove all definitions not needed to run the page handlers that are visible in the signature of the last module listed in the \texttt{.urp} file. -\subsection{Tag} +\subsection{\label{tag}Tag} Assign a URL name to each link and form action. It is important that these links and actions are written as applications of named functions, because such names are used to generate URL patterns. A URL pattern has a name built from the full module path of the named function, followed by the function name, with all pieces separated by slashes. The path of a functor application is based on the name given to the result, rather than the path of the functor itself. -- cgit v1.2.3 From a317e5050fe88a8672a5da5faa2d7180ab285a0d Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 7 Dec 2008 15:10:59 -0500 Subject: Intro --- doc/manual.tex | 29 ++++++++++++++++++++++++++++- 1 file changed, 28 insertions(+), 1 deletion(-) diff --git a/doc/manual.tex b/doc/manual.tex index 46404f7c..8d507792 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -1,5 +1,5 @@ \documentclass{article} -\usepackage{fullpage,amsmath,amssymb,proof} +\usepackage{fullpage,amsmath,amssymb,proof,url} \newcommand{\cd}[1]{\texttt{#1}} \newcommand{\mt}[1]{\mathsf{#1}} @@ -17,6 +17,33 @@ \tableofcontents + +\section{Introduction} + +\emph{Ur} is a programming language designed to introduce richer type system features into functional programming in the tradition of ML and Haskell. Ur is functional, pure, statically-typed, and strict. Ur supports a powerful kind of \emph{metaprogramming} based on \emph{row types}. + +\emph{Ur/Web} is Ur plus a special standard library and associated rules for parsing and optimization. Ur/Web supports construction of dynamic web applications backed by SQL databases. The signature of the standard library is such that well-typed Ur/Web programs ``don't go wrong'' in a very broad sense. Not only do they not crash during particular page generations, but they also may not: + +\begin{itemize} +\item Suffer from any kinds of code-injection attacks +\item Return invalid HTML +\item Contain dead intra-application links +\item Have mismatches between HTML forms and the fields expected by their handlers +\item Attempt invalid SQL queries +\item Use improper marshaling or unmarshaling in communication with SQL databases +\end{itemize} + +This type safety is just the foundation of the Ur/Web methodology. It is also possible to use metaprogramming to build significant application pieces by analysis of type structure. For instance, the demo includes an ML-style functor for building an admin interface for an arbitrary SQL table. The type system guarantees that the admin interface sub-application that comes out will always be free of the above-listed bugs, no matter which well-typed table description is given as input. + +The Ur/Web compiler also produces very efficient object code that does not use garbage collection. These compiled programs will often be even more efficient than what most programmers would bother to write in C. + +\medskip + +The official web site for Ur is: +\begin{center} + \url{http://www.impredicative.com/ur/} +\end{center} + \section{Ur Syntax} In this section, we describe the syntax of Ur, deferring to a later section discussion of most of the syntax specific to SQL and XML. The sole exceptions are the declaration forms for tables, sequences, and cookies. -- cgit v1.2.3 From d3a3f5f7e087580215f82afe90a4f64f1a75ebc1 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 9 Dec 2008 11:40:51 -0500 Subject: Installation --- doc/manual.tex | 55 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) diff --git a/doc/manual.tex b/doc/manual.tex index 8d507792..942cee77 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -44,6 +44,61 @@ The official web site for Ur is: \url{http://www.impredicative.com/ur/} \end{center} + +\section{Installation} + +If you are lucky, then the following standard command sequence will suffice for installation, in a directory to which you have unpacked the latest distribution tarball. + +\begin{verbatim} +./configure +make +sudo make install +\end{verbatim} + +Some other packages must be installed for the above to work. At a minimum, you need a standard UNIX shell, with standard UNIX tools like sed and GCC in your execution path; and MLton, the whole-program optimizing compiler for Standard ML. To build programs that access SQL databases, you also need libpq, the PostgreSQL client library. As of this writing, in the ``testing'' version of Debian Linux, this command will install the more uncommon of these dependencies: + +\begin{verbatim} +apt-get install mlton libpq-dev +\end{verbatim} + +It is also possible to access the modules of the Ur/Web compiler interactively, within Standard ML of New Jersey. To install the prerequisites in Debian testing: + +\begin{verbatim} +apt-get install smlnj libsmlnj-smlnj ml-yacc ml-lpt +\end{verbatim} + +To begin an interactive session with the Ur compiler modules, run \texttt{make smlnj}, and then, from within an \texttt{sml} session, run \texttt{CM.make "src/urweb.cm";}. The \texttt{Compiler} module is the main entry point. + +To run an SQL-backed application, you will probably want to install the PostgreSQL server. Version 8.3 or higher is required. + +\begin{verbatim} +apt-get install postgresql-8.3 +\end{verbatim} + +To use the Emacs mode, you must have a modern Emacs installed. We assume that you already know how to do this, if you're in the business of looking for an Emacs mode. The demo generation facility of the compiler will also call out to Emacs to syntax-highlight code, and that process depends on the \texttt{htmlize} module, which can be installed in Debian testing via: + +\begin{verbatim} +apt-get install emacs-goodies-el +\end{verbatim} + +Even with the right packages installed, configuration and building might fail to work. After you run \texttt{./configure}, you will see the values of some named environment variables printed. You may need to adjust these values to get proper installation for your system. To change a value, store your preferred alternative in the corresponding UNIX environment variable, before running \texttt{./configure}. For instance, here is how to change the list of extra arguments that the Ur/Web compiler will pass to GCC on every invocation. + +\begin{verbatim} +GCCARGS=-fnested-functions ./configure +\end{verbatim} + +Some OSX users have reported needing to use this particular GCCARGS value. + +The Emacs mode can be set to autoload by adding the following to your \texttt{.emacs} file. + +\begin{verbatim} +(add-to-list 'load-path "/usr/local/share/emacs/site-lisp/urweb-mode") +(load "urweb-mode-startup") +\end{verbatim} + +Change the path in the first line if you chose a different Emacs installation path during configuration. + + \section{Ur Syntax} In this section, we describe the syntax of Ur, deferring to a later section discussion of most of the syntax specific to SQL and XML. The sole exceptions are the declaration forms for tables, sequences, and cookies. -- cgit v1.2.3 From 5bb4dcc90dc61ef431539e049b160e2971cf4621 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 9 Dec 2008 11:52:56 -0500 Subject: .urp files --- doc/manual.tex | 30 ++++++++++++++++++++++++++++++ 1 file changed, 30 insertions(+) diff --git a/doc/manual.tex b/doc/manual.tex index 942cee77..141c4b45 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -99,6 +99,36 @@ The Emacs mode can be set to autoload by adding the following to your \texttt{.e Change the path in the first line if you chose a different Emacs installation path during configuration. +\section{Command-Line Compiler} + +\subsection{Project Files} + +The basic inputs to the \texttt{urweb} compiler are project files, which have the extension \texttt{.urp}. Here is a sample \texttt{.urp} file. + +\begin{verbatim} +database dbname=test +sql crud1.sql + +crud +crud1 +\end{verbatim} + +The \texttt{database} line gives the database information string to pass to libpq. In this case, the string only says to connect to a local database named \texttt{test}. + +The \texttt{sql} line asks for an SQL source file to be generated, giving the commands to run to create the tables and sequences that this application expects to find. After building this \texttt{.urp} file, the following commands could be used to initialize the database, assuming that the current UNIX user exists as a Postgres user with database creation privileges: + +\begin{verbatim} +createdb test +psql -f crud1.sql test +\end{verbatim} + +A blank line always separates the named directives from a list of modules to include in the project; if there are no named directives, a blank line must begin the file. + +For each entry \texttt{M} in the module list, the file \texttt{M.urs} is included in the project if it exists, and the file \texttt{M.ur} must exist and is always included. + +A few other named directives are supported. \texttt{prefix PREFIX} sets the prefix included before every URI within the generated application; the default is \texttt{/}. \texttt{exe FILENAME} sets the filename to which to write the output executable; the default for file \texttt{P.urp} is \texttt{P.exe}. \texttt{debug} saves some intermediate C files, which is mostly useful to help in debugging the compiler itself. \texttt{profile} generates an executable that may be used with gprof. + + \section{Ur Syntax} In this section, we describe the syntax of Ur, deferring to a later section discussion of most of the syntax specific to SQL and XML. The sole exceptions are the declaration forms for tables, sequences, and cookies. -- cgit v1.2.3 From 86360921e7d299c1e20c0adc5d382f70b64b822f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 9 Dec 2008 11:57:17 -0500 Subject: Building an application --- doc/manual.tex | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/doc/manual.tex b/doc/manual.tex index 141c4b45..9255fc87 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -128,6 +128,18 @@ For each entry \texttt{M} in the module list, the file \texttt{M.urs} is include A few other named directives are supported. \texttt{prefix PREFIX} sets the prefix included before every URI within the generated application; the default is \texttt{/}. \texttt{exe FILENAME} sets the filename to which to write the output executable; the default for file \texttt{P.urp} is \texttt{P.exe}. \texttt{debug} saves some intermediate C files, which is mostly useful to help in debugging the compiler itself. \texttt{profile} generates an executable that may be used with gprof. +\subsection{Building an Application} + +To compile project \texttt{P.urp}, simply run +\begin{verbatim} +urweb P +\end{verbatim} + +To time how long the different compiler phases run, without generating an executable, run +\begin{verbatim} +urweb -timing P +\end{verbatim} + \section{Ur Syntax} -- cgit v1.2.3 From 55fefa6122803e9739e9e71f1d50eae671665df4 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 9 Dec 2008 14:06:51 -0500 Subject: Proofreading pass --- doc/manual.tex | 45 ++++++++++++++++++++++----------------------- 1 file changed, 22 insertions(+), 23 deletions(-) diff --git a/doc/manual.tex b/doc/manual.tex index 9255fc87..3c97b720 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -134,6 +134,7 @@ To compile project \texttt{P.urp}, simply run \begin{verbatim} urweb P \end{verbatim} +The output executable is a standalone web server. Run it with the command-line argument \texttt{-h} to see which options it takes. If the project file lists a database, the web server will attempt to connect to that database on startup. To time how long the different compiler phases run, without generating an executable, run \begin{verbatim} @@ -188,7 +189,7 @@ $$\begin{array}{rrcll} Ur supports several different notions of functions that take types as arguments. These arguments can be either implicit, causing them to be inferred at use sites; or explicit, forcing them to be specified manually at use sites. There is a common explicitness annotation convention applied at the definitions of and in the types of such functions. $$\begin{array}{rrcll} \textrm{Explicitness} & ? &::=& :: & \textrm{explicit} \\ - &&& \; ::: & \textrm{implicit} + &&& ::: & \textrm{implicit} \end{array}$$ \emph{Constructors} are the main class of compile-time-only data. They include proper types and are classified by kinds. @@ -210,7 +211,7 @@ $$\begin{array}{rrcll} &&& c \rc c & \textrm{type-level record concatenation} \\ &&& \mt{fold} & \textrm{type-level record fold} \\ \\ - &&& (c^+) & \textrm{type-level tuple} \\ + &&& (c,^+) & \textrm{type-level tuple} \\ &&& c.n & \textrm{type-level tuple projection ($n \in \mathbb N^+$)} \\ \\ &&& \lambda [c \sim c] \Rightarrow c & \textrm{guarded constructor} \\ @@ -452,9 +453,9 @@ $$\infer{\Gamma \vdash \lambda [c_1 \sim c_2] \Rightarrow c :: \kappa}{ We will use a keyword $\mt{map}$ as a shorthand, such that, for $f$ of kind $\kappa \to \kappa'$, $\mt{map} \; f$ stands for $\mt{fold} \; (\lambda (x_1 :: \mt{Name}) (x_2 :: \kappa) (x_3 :: \{\kappa'\}) \Rightarrow [x_1 = f \; x_2] \rc x_3) \; []$. $$\infer{\Gamma \vdash c_1 \sim c_2}{ - \Gamma \vdash c_1 \hookrightarrow c'_1 - & \Gamma \vdash c_2 \hookrightarrow c'_2 - & \forall c''_1 \in c'_1, c''_2 \in c'_2: \Gamma \vdash c''_1 \sim c''_2 + \Gamma \vdash c_1 \hookrightarrow C_1 + & \Gamma \vdash c_2 \hookrightarrow C_2 + & \forall c'_1 \in C_1, c'_2 \in C_2: \Gamma \vdash c'_1 \sim c'_2 } \quad \infer{\Gamma \vdash X \sim X'}{ X \neq X' @@ -462,10 +463,10 @@ $$\infer{\Gamma \vdash c_1 \sim c_2}{ $$\infer{\Gamma \vdash c_1 \sim c_2}{ c'_1 \sim c'_2 \in \Gamma - & \Gamma \vdash c'_1 \hookrightarrow c''_1 - & \Gamma \vdash c'_2 \hookrightarrow c''_2 - & c_1 \in c''_1 - & c_2 \in c''_2 + & \Gamma \vdash c'_1 \hookrightarrow C_1 + & \Gamma \vdash c'_2 \hookrightarrow C_2 + & c_1 \in C_1 + & c_2 \in C_2 }$$ $$\infer{\Gamma \vdash c \hookrightarrow \{c\}}{} @@ -656,8 +657,7 @@ We use an auxiliary judgment $\overline{y}; x; \Gamma \vdash \overline{dc} \lead This is the first judgment where we deal with type classes, for the $\mt{class}$ declaration form. We will omit their special handling in this formal specification. Section \ref{typeclasses} gives an informal description of how type classes influence type inference. -We presuppose the existence of a function $\mathcal O$, where $\mathcal(M, \overline{s})$ implements the $\mt{open}$ declaration by producing a context with the appropriate entry for each available component of module $M$ with signature items $\overline{s}$. Where possible, $\mathcal O$ uses ``transparent'' entries (e.g., an abstract type $M.x$ is mapped to $x :: \mt{Type} = M.x$), so that the relationship with $M$ is maintained. A related function $\mathcal O_c$ builds a context containing the disjointness constraints found in $S$. - +We presuppose the existence of a function $\mathcal O$, where $\mathcal O(M, \overline{s})$ implements the $\mt{open}$ declaration by producing a context with the appropriate entry for each available component of module $M$ with signature items $\overline{s}$. Where possible, $\mathcal O$ uses ``transparent'' entries (e.g., an abstract type $M.x$ is mapped to $x :: \mt{Type} = M.x$), so that the relationship with $M$ is maintained. A related function $\mathcal O_c$ builds a context containing the disjointness constraints found in $\overline s$. We write $\kappa_1^n \to \kappa$ as a shorthand, where $\kappa_1^0 \to \kappa = \kappa$ and $\kappa_1^{n+1} \to \kappa_2 = \kappa_1 \to (\kappa_1^n \to \kappa_2)$. We write $\mt{len}(\overline{y})$ for the length of vector $\overline{y}$ of variables. $$\infer{\Gamma \vdash \cdot \leadsto \Gamma}{} @@ -690,10 +690,10 @@ $$\infer{\Gamma \vdash \mt{val} \; \mt{rec} \; \overline{x : \tau = e} \leadsto $$\infer{\Gamma \vdash \mt{structure} \; X : S = M \leadsto \Gamma, X : S}{ \Gamma \vdash M : S - & \textrm{ ($M$ not a $\mt{struct} \; \ldots \; \mt{end}$)} + & \textrm{ $M$ not a constant or application} } -\quad \infer{\Gamma \vdash \mt{structure} \; X : S = \mt{struct} \; \overline{d} \; \mt{end} \leadsto \Gamma, X : \mt{selfify}(X, \overline{s})}{ - \Gamma \vdash \mt{struct} \; \overline{d} \; \mt{end} : \mt{sig} \; \overline{s} \; \mt{end} +\quad \infer{\Gamma \vdash \mt{structure} \; X : S = M \leadsto \Gamma, X : \mt{selfify}(X, \overline{s})}{ + \Gamma \vdash M : \mt{sig} \; \overline{s} \; \mt{end} }$$ $$\infer{\Gamma \vdash \mt{signature} \; X = S \leadsto \Gamma, X = S}{ @@ -786,7 +786,7 @@ $$\infer{\Gamma \vdash \mt{class} \; x = c \leadsto \Gamma, x :: \mt{Type} \to \ \subsection{Signature Compatibility} -To simplify the judgments in this section, we assume that all signatures are alpha-varied as necessary to avoid including mmultiple bindings for the same identifier. This is in addition to the usual alpha-variation of locally-bound variables. +To simplify the judgments in this section, we assume that all signatures are alpha-varied as necessary to avoid including multiple bindings for the same identifier. This is in addition to the usual alpha-variation of locally-bound variables. We rely on a judgment $\Gamma \vdash \overline{s} \leq s'$, which expresses the occurrence in signature items $\overline{s}$ of an item compatible with $s'$. We also use a judgment $\Gamma \vdash \overline{dc} \leq \overline{dc}$, which expresses compatibility of datatype definitions. @@ -835,7 +835,7 @@ $$\infer{\Gamma \vdash \mt{functor} (X : S_1) : S_2 \leq \mt{functor} (X : S'_1) $$\infer{\Gamma \vdash \mt{con} \; x :: \kappa \leq \mt{con} \; x :: \kappa}{} \quad \infer{\Gamma \vdash \mt{con} \; x :: \kappa = c \leq \mt{con} \; x :: \kappa}{} -\quad \infer{\Gamma \vdash \mt{datatype} \; x \; \overline{y} = \overline{dc} \leq \mt{con} \; x :: \mt{Type}}{}$$ +\quad \infer{\Gamma \vdash \mt{datatype} \; x \; \overline{y} = \overline{dc} \leq \mt{con} \; x :: \mt{Type}^{\mt{len}(\overline y)} \to \mt{Type}}{}$$ $$\infer{\Gamma \vdash \mt{datatype} \; x = \mt{datatype} \; M.z \leq \mt{con} \; x :: \mt{Type}^{\mt{len}(y)} \to \mt{Type}}{ \Gamma \vdash M : \mt{sig} \; \overline{s} \; \mt{end} @@ -946,10 +946,9 @@ $$\infer{\Gamma \vdash M_1(M_2) : [X \mapsto M_2]S_2}{ \mt{sigOf}(\mt{cookie} \; x : \tau) &=& \mt{cookie} \; x : \tau \\ \mt{sigOf}(\mt{class} \; x = c) &=& \mt{class} \; x = c \\ \end{eqnarray*} - \begin{eqnarray*} \mt{selfify}(M, \cdot) &=& \cdot \\ - \mt{selfify}(M, s \; \overline{s'}) &=& \mt{selfify}(M, \sigma, s) \; \mt{selfify}(M, \overline{s'}) \\ + \mt{selfify}(M, s \; \overline{s'}) &=& \mt{selfify}(M, s) \; \mt{selfify}(M, \overline{s'}) \\ \\ \mt{selfify}(M, \mt{con} \; x :: \kappa) &=& \mt{con} \; x :: \kappa = M.x \\ \mt{selfify}(M, \mt{con} \; x :: \kappa = c) &=& \mt{con} \; x :: \kappa = c \\ @@ -984,7 +983,7 @@ $$\infer{\Gamma \vdash M_1(M_2) : [X \mapsto M_2]S_2}{ \mt{proj}(M, \mt{datatype} \; x = \mt{datatype} \; M'.z, \mt{val} \; X) &=& \overline{y ::: \mt{Type}} \to M.x \; \overline y \textrm{ (where $\Gamma \vdash M' : \mt{sig} \; \overline{s'} \; \mt{end}$} \\ && \textrm{and $\mt{proj}(M', \overline{s'}, \mt{datatype} \; z = (\overline{y}, \overline{dc})$ and $X \in \overline{dc}$)} \\ \mt{proj}(M, \mt{datatype} \; x = \mt{datatype} \; M'.z, \mt{val} \; X) &=& \overline{y ::: \mt{Type}} \to \tau \to M.x \; \overline y \textrm{ (where $\Gamma \vdash M' : \mt{sig} \; \overline{s'} \; \mt{end}$} \\ - && \textrm{and $\mt{proj}(M', \overline{s'}, \mt{datatype} \; z = (\overline{y}, \overline{dc})$ and $X : \tau \in \overline{dc}$)} \\ + && \textrm{and $\mt{proj}(M', \overline{s'}, \mt{datatype} \; z = (\overline{y}, \overline{dc})$ and $X \; \mt{of} \; \tau \in \overline{dc}$)} \\ \\ \mt{proj}(M, \mt{structure} \; X : S \; \overline{s}, \mt{structure} \; X) &=& S \\ \\ @@ -1391,7 +1390,7 @@ $$\begin{array}{rrcll} \textrm{Projections} & P &::=& \ast & \textrm{all columns} \\ &&& p,^+ & \textrm{particular columns} \\ \textrm{Pre-projections} & p &::=& t.f & \textrm{one column from a table} \\ - &&& t.\{\{c\}\} & \textrm{a record of colums from a table (of kind $\{\mt{Type}\}$)} \\ + &&& t.\{\{c\}\} & \textrm{a record of columns from a table (of kind $\{\mt{Type}\}$)} \\ \textrm{Table names} & t &::=& x & \textrm{constant table name (automatically capitalized)} \\ &&& X & \textrm{constant table name} \\ &&& \{\{c\}\} & \textrm{computed table name (of kind $\mt{Name}$)} \\ @@ -1462,7 +1461,7 @@ When the standalone web server receives a request for a known page, it calls the HTML forms are handled in a similar way. The $\mt{action}$ attribute of a $\mt{submit}$ form tag takes a value of type $\$\mt{use} \to \mt{transaction} \; \mt{page}$, where $\mt{use}$ is a kind-$\{\mt{Type}\}$ record of the form fields used by this action handler. Action handlers are assigned URL patterns in the same way as above. -For both links and actions, direct arguments and local variables mentioned implicitly via closures are automatically included in serialized form in URLs, in the order in which they appeared in the source code. +For both links and actions, direct arguments and local variables mentioned implicitly via closures are automatically included in serialized form in URLs, in the order in which they appear in the source code. \section{Compiler Phases} @@ -1513,11 +1512,11 @@ This phase specializes polymorphic functions to the specific arguments passed to \subsection{Specialize} -Replace uses of parametrized datatypes with versions specialized to specific parameters. As for Unpoly, this phase will not be effective enough in the presence of polymorphic recursion or other fancy uses of impredicative polymorphism. +Replace uses of parameterized datatypes with versions specialized to specific parameters. As for Unpoly, this phase will not be effective enough in the presence of polymorphic recursion or other fancy uses of impredicative polymorphism. \subsection{Shake} -Here the compiler repeats the earlier shake phase. +Here the compiler repeats the earlier Shake phase. \subsection{Monoize} -- 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 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 5d92ee7289e6df76694bebaa585160e5b3c79013 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 9 Dec 2008 14:43:43 -0500 Subject: Spell check --- doc/manual.tex | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/manual.tex b/doc/manual.tex index 21092735..930fd9f9 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -1009,9 +1009,9 @@ The Ur/Web compiler uses \emph{heuristic type inference}, with no claims of comp \subsection{Basic Unification} -Type-checkers for languages based on the Hindly-Milner type discipline, like ML and Haskell, take advantage of \emph{principal typing} properties, making complete type inference relatively straightforward. Inference algorithms are traditionally implemented using type unification variables, at various points asserting equalities between types, in the process discovering the values of type variables. The Ur/Web compiler uses the same basic strategy, but the complexity of the type system rules out easy completeness. +Type-checkers for languages based on the Hindley-Milner type discipline, like ML and Haskell, take advantage of \emph{principal typing} properties, making complete type inference relatively straightforward. Inference algorithms are traditionally implemented using type unification variables, at various points asserting equalities between types, in the process discovering the values of type variables. The Ur/Web compiler uses the same basic strategy, but the complexity of the type system rules out easy completeness. -Type-checking can require evaluating recursive functional programs, thanks to the type-level $\mt{fold}$ operator. When a unification variable appears in such a type, the next step of computation can be undetermined. The value of that variable might be determined later, but this would be ``too late'' for the unification problems generated at the first occurrence. This is the essential source of incompletness. +Type-checking can require evaluating recursive functional programs, thanks to the type-level $\mt{fold}$ operator. When a unification variable appears in such a type, the next step of computation can be undetermined. The value of that variable might be determined later, but this would be ``too late'' for the unification problems generated at the first occurrence. This is the essential source of incompleteness. Nonetheless, the unification engine tends to do reasonably well. Unlike in ML, polymorphism is never inferred in definitions; it must be indicated explicitly by writing out constructor-level parameters. By writing these and other annotations, the programmer can generally get the type inference engine to do most of the type reconstruction work. @@ -1155,7 +1155,7 @@ $$\begin{array}{l} \mt{val} \; \mt{sql\_subset\_all} : \mt{tables} :: \{\{\mt{Type}\}\} \to \mt{sql\_subset} \; \mt{tables} \; \mt{tables} \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. +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-availability 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}$$ -- cgit v1.2.3 From a69a769216ef5fa9e96168ca21d110f79c22f547 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 9 Dec 2008 14:44:52 -0500 Subject: Prepare to release --- CHANGELOG | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/CHANGELOG b/CHANGELOG index 7ba7088e..447761d5 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,9 +1,11 @@ ======== +20081209 ======== - Optimization: Fusing page writes with calls to recursive functions - Optimization of bottleneck compiler phases -- Start of manual +- Reference manual +- SQL arithmetic operators ======== 20081120 -- cgit v1.2.3 From 8d98194908d9001ce5da0bceda10c22e71e940ba Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 19 Dec 2008 09:35:44 -0500 Subject: Add initial C support for reactive --- Makefile.in | 4 ++-- include/urweb.h | 4 +++- src/c/driver.c | 2 +- src/c/urweb.c | 62 +++++++++++++++++++++++++++++++++++++++++++++++---------- 4 files changed, 57 insertions(+), 15 deletions(-) diff --git a/Makefile.in b/Makefile.in index a12cb59b..57a083bd 100644 --- a/Makefile.in +++ b/Makefile.in @@ -20,10 +20,10 @@ clean: clib/*.o rm -rf .cm src/.cm -clib/urweb.o: src/c/urweb.c +clib/urweb.o: src/c/urweb.c include/*.h gcc -O3 -I include -c src/c/urweb.c -o clib/urweb.o $(CFLAGS) -clib/driver.o: src/c/driver.c +clib/driver.o: src/c/driver.c include/*.h gcc -O3 -I include -c src/c/driver.c -o clib/driver.o $(CFLAGS) src/urweb.cm: src/prefix.cm src/sources diff --git a/include/urweb.h b/include/urweb.h index ad08c811..c021c3dd 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 outHeaders_len, size_t page_len, size_t heap_len); +uw_context uw_init(size_t outHeaders_len, size_t script_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); @@ -36,6 +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); + 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); diff --git a/src/c/driver.c b/src/c/driver.c index df154aea..a25cd743 100644 --- a/src/c/driver.c +++ b/src/c/driver.c @@ -73,7 +73,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(0, 1024, 0); + uw_context ctx = uw_init(0, 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 253cda87..f9b623a4 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -31,6 +31,9 @@ struct uw_context { char *heap, *heap_front, *heap_back; char **inputs; + char *script, *script_front, *script_back; + int reactive_count; + void *db; jmp_buf jmp_buf; @@ -44,7 +47,7 @@ struct uw_context { extern int uw_inputs_len; -uw_context uw_init(size_t outHeaders_len, size_t page_len, size_t heap_len) { +uw_context uw_init(size_t outHeaders_len, size_t script_len, size_t page_len, size_t heap_len) { uw_context ctx = malloc(sizeof(struct uw_context)); ctx->headers = ctx->headers_end = NULL; @@ -70,6 +73,10 @@ uw_context uw_init(size_t outHeaders_len, size_t page_len, size_t heap_len) { ctx->error_message[0] = 0; + ctx->script_front = ctx->script = malloc(script_len); + ctx->script_back = ctx->script_front + script_len; + ctx->reactive_count = 0; + return ctx; } @@ -83,6 +90,7 @@ void *uw_get_db(uw_context ctx) { void uw_free(uw_context ctx) { free(ctx->outHeaders); + free(ctx->script); free(ctx->page); free(ctx->heap); free(ctx->inputs); @@ -90,22 +98,19 @@ void uw_free(uw_context ctx) { free(ctx); } -void uw_reset_keep_request(uw_context ctx) { +void uw_reset_keep_error_message(uw_context ctx) { ctx->outHeaders_front = ctx->outHeaders; + ctx->script_front = ctx->script; ctx->page_front = ctx->page; ctx->heap_front = ctx->heap; ctx->regions = NULL; ctx->cleanup_front = ctx->cleanup; - - ctx->error_message[0] = 0; + ctx->reactive_count = 0; } -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; - ctx->cleanup_front = ctx->cleanup; +void uw_reset_keep_request(uw_context ctx) { + uw_reset_keep_error_message(ctx); + ctx->error_message[0] = 0; } void uw_reset(uw_context ctx) { @@ -286,6 +291,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("Script: %d/%d\n", ctx->script_front - ctx->script, ctx->script_back - ctx->script); 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); } @@ -341,7 +347,41 @@ void uw_write_header(uw_context ctx, uw_Basis_string s) { uw_check_headers(ctx, len + 1); strcpy(ctx->outHeaders_front, s); ctx->outHeaders_front += len; - *ctx->outHeaders_front = 0; +} + +static void uw_check_script(uw_context ctx, size_t extra) { + size_t desired = ctx->script_front - ctx->script + extra, next; + char *new_script; + + next = ctx->script_back - ctx->script; + if (next < desired) { + if (next == 0) + next = 1; + for (; next < desired; next *= 2); + + new_script = realloc(ctx->script, next); + ctx->script_front = new_script + (ctx->script_front - ctx->script); + ctx->script_back = new_script + next; + ctx->script = new_script; + } +} + +void uw_write_script(uw_context ctx, uw_Basis_string s) { + int len = strlen(s); + + uw_check_script(ctx, len + 1); + strcpy(ctx->script_front, s); + ctx->script_front += len; +} + +int uw_Basis_new_client_reactive(uw_context ctx) { + size_t len; + + uw_check_script(ctx, 8 + INTS_MAX); + sprintf(ctx->script_front, "var e%d=0\n%n", ctx->reactive_count, &len); + ctx->script_front += len; + + return ctx->reactive_count++; } static void uw_check(uw_context ctx, size_t extra) { -- cgit v1.2.3 From ba83ee9a9b3d2539b820c9fcb1cb7cd42226da6c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 19 Dec 2008 10:03:31 -0500 Subject: Initial conversion to arbitrary-kind classes --- src/elab.sml | 6 +-- src/elab_env.sml | 36 ++++++++-------- src/elab_print.sml | 46 +++++++++++++-------- src/elab_util.sml | 43 +++++++++++-------- src/elaborate.sml | 115 +++++++++++++++++++++++++++------------------------ src/explify.sml | 10 ++--- src/source.sml | 6 +-- src/source_print.sml | 44 ++++++++++++-------- src/urweb.grm | 49 ++++++++++++++++++---- 9 files changed, 212 insertions(+), 143 deletions(-) diff --git a/src/elab.sml b/src/elab.sml index d997b7ec..8e44c43c 100644 --- a/src/elab.sml +++ b/src/elab.sml @@ -136,8 +136,8 @@ datatype sgn_item' = | SgiStr of string * int * sgn | SgiSgn of string * int * sgn | SgiConstraint of con * con - | SgiClassAbs of string * int - | SgiClass of string * int * con + | SgiClassAbs of string * int * kind + | SgiClass of string * int * kind * con and sgn' = SgnConst of sgn_item list @@ -163,7 +163,7 @@ datatype decl' = | DExport of int * sgn * str | DTable of int * string * int * con | DSequence of int * string * int - | DClass of string * int * con + | DClass of string * int * kind * con | DDatabase of string | DCookie of int * string * int * con diff --git a/src/elab_env.sml b/src/elab_env.sml index d1084d0c..53c934dd 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -604,8 +604,8 @@ fun sgiSeek (sgi, (sgns, strs, cons)) = | SgiSgn (x, n, _) => (IM.insert (sgns, n, x), strs, cons) | SgiStr (x, n, _) => (sgns, IM.insert (strs, n, x), cons) | SgiConstraint _ => (sgns, strs, cons) - | SgiClassAbs (x, n) => (sgns, strs, IM.insert (cons, n, x)) - | SgiClass (x, n, _) => (sgns, strs, IM.insert (cons, n, x)) + | SgiClassAbs (x, n, _) => (sgns, strs, IM.insert (cons, n, x)) + | SgiClass (x, n, _, _) => (sgns, strs, IM.insert (cons, n, x)) fun sgnSeek f sgis = let @@ -788,8 +788,8 @@ fun enrichClasses env classes (m1, ms) sgn = fmap, pushSgnNamedAs env x n sgn) - | SgiClassAbs xn => found xn - | SgiClass (x, n, _) => found (x, n) + | SgiClassAbs (x, n, _) => found (x, n) + | SgiClass (x, n, _, _) => found (x, n) | SgiVal (x, n, (CApp (f, a), _)) => let fun unravel c = @@ -946,8 +946,8 @@ fun sgiBinds env (sgi, loc) = | SgiSgn (x, n, sgn) => pushSgnNamedAs env x n sgn | SgiConstraint _ => env - | SgiClassAbs (x, n) => pushCNamedAs env x n (KArrow ((KType, loc), (KType, loc)), loc) NONE - | SgiClass (x, n, c) => pushCNamedAs env x n (KArrow ((KType, loc), (KType, loc)), loc) (SOME c) + | SgiClassAbs (x, n, k) => pushCNamedAs env x n (KArrow (k, (KType, loc)), loc) NONE + | SgiClass (x, n, k, c) => pushCNamedAs env x n (KArrow (k, (KType, loc)), loc) (SOME c) fun sgnSubCon x = ElabUtil.Con.map {kind = id, @@ -998,14 +998,14 @@ fun projectCon env {sgn, str, field} = end else NONE - | SgiClassAbs (x, _) => if x = field then - SOME ((KArrow ((KType, #2 sgn), (KType, #2 sgn)), #2 sgn), NONE) - else - NONE - | SgiClass (x, _, c) => if x = field then - SOME ((KArrow ((KType, #2 sgn), (KType, #2 sgn)), #2 sgn), SOME c) - else - NONE + | SgiClassAbs (x, _, k) => if x = field then + SOME ((KArrow (k, (KType, #2 sgn)), #2 sgn), NONE) + else + NONE + | SgiClass (x, _, k, c) => if x = field then + SOME ((KArrow (k, (KType, #2 sgn)), #2 sgn), SOME c) + else + NONE | _ => NONE) sgis of NONE => NONE | SOME ((k, co), subs) => SOME (k, Option.map (sgnSubCon (str, subs)) co)) @@ -1101,8 +1101,8 @@ fun sgnSeekConstraints (str, sgis) = | SgiVal _ => seek (sgis, sgns, strs, cons, acc) | SgiSgn (x, n, _) => seek (sgis, IM.insert (sgns, n, x), strs, cons, acc) | SgiStr (x, n, _) => seek (sgis, sgns, IM.insert (strs, n, x), cons, acc) - | SgiClassAbs (x, n) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) - | SgiClass (x, n, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) + | SgiClassAbs (x, n, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) + | SgiClass (x, n, _, _) => seek (sgis, sgns, strs, IM.insert (cons, n, x), acc) in seek (sgis, IM.empty, IM.empty, IM.empty, []) end @@ -1189,9 +1189,9 @@ fun declBinds env (d, loc) = in pushENamedAs env x n t end - | DClass (x, n, c) => + | DClass (x, n, k, c) => let - val k = (KArrow ((KType, loc), (KType, loc)), loc) + val k = (KArrow (k, (KType, loc)), loc) val env = pushCNamedAs env x n k (SOME c) in pushClass env n diff --git a/src/elab_print.sml b/src/elab_print.sml index 2f652737..0e6c9767 100644 --- a/src/elab_print.sml +++ b/src/elab_print.sml @@ -534,16 +534,24 @@ fun p_sgn_item env (sgi, _) = string "~", space, p_con env c2] - | SgiClassAbs (x, n) => box [string "class", - space, - p_named x n] - | SgiClass (x, n, c) => box [string "class", - space, - p_named x n, - space, - string "=", - space, - p_con env c] + | SgiClassAbs (x, n, k) => box [string "class", + space, + p_named x n, + space, + string "::", + space, + p_kind k] + | SgiClass (x, n, k, c) => box [string "class", + space, + p_named x n, + space, + string "::", + space, + p_kind k, + space, + string "=", + space, + p_con env c] and p_sgn env (sgn, _) = case sgn of @@ -705,13 +713,17 @@ fun p_decl env (dAll as (d, _) : decl) = | DSequence (_, x, n) => box [string "sequence", space, p_named x n] - | DClass (x, n, c) => box [string "class", - space, - p_named x n, - space, - string "=", - space, - p_con env c] + | DClass (x, n, k, c) => box [string "class", + space, + p_named x n, + space, + string "::", + space, + p_kind k, + space, + string "=", + space, + p_con env c] | DDatabase s => box [string "database", space, string s] diff --git a/src/elab_util.sml b/src/elab_util.sml index 6e2c76f6..6e78907d 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -547,11 +547,16 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = S.map2 (con ctx c2, fn c2' => (SgiConstraint (c1', c2'), loc))) - | SgiClassAbs _ => S.return2 siAll - | SgiClass (x, n, c) => - S.map2 (con ctx c, - fn c' => - (SgiClass (x, n, c'), loc)) + | SgiClassAbs (x, n, k) => + S.map2 (kind k, + fn k' => + (SgiClassAbs (x, n, k'), loc)) + | SgiClass (x, n, k, c) => + S.bind2 (kind k, + fn k' => + S.map2 (con ctx c, + fn c' => + (SgiClass (x, n, k', c'), loc))) and sg ctx s acc = S.bindP (sg' ctx s acc, sgn ctx) @@ -575,10 +580,10 @@ fun mapfoldB {kind, con, sgn_item, sgn, bind} = | SgiSgn (x, _, sgn) => bind (ctx, Sgn (x, sgn)) | SgiConstraint _ => ctx - | SgiClassAbs (x, n) => - bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))) - | SgiClass (x, n, _) => - bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))), + | SgiClassAbs (x, n, k) => + bind (ctx, NamedC (x, n, (KArrow (k, (KType, loc)), loc))) + | SgiClass (x, n, k, _) => + bind (ctx, NamedC (x, n, (KArrow (k, (KType, loc)), loc))), sgi ctx si)) ctx sgis, fn sgis' => (SgnConst sgis', loc)) @@ -720,8 +725,8 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f c), loc))) | DSequence (tn, x, n) => bind (ctx, NamedE (x, (CModProj (n, [], "sql_sequence"), loc))) - | DClass (x, n, _) => - bind (ctx, NamedC (x, n, (KArrow ((KType, loc), (KType, loc)), loc))) + | DClass (x, n, k, _) => + bind (ctx, NamedC (x, n, (KArrow (k, (KType, loc)), loc))) | DDatabase _ => ctx | DCookie (tn, x, n, c) => bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "cookie"), loc), @@ -819,10 +824,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, sgn_item = fsgi, sgn = fsg, str = f (DTable (tn, x, n, c'), loc)) | DSequence _ => S.return2 dAll - | DClass (x, n, c) => - S.map2 (mfc ctx c, - fn c' => - (DClass (x, n, c'), loc)) + | DClass (x, n, k, c) => + S.bind2 (mfk k, + fn k' => + S.map2 (mfc ctx c, + fn c' => + (DClass (x, n, k', c'), loc))) | DDatabase _ => S.return2 dAll @@ -963,7 +970,7 @@ and maxNameDecl (d, _) = | DSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn) | DFfiStr (_, n, sgn) => Int.max (n, maxNameSgn sgn) | DConstraint _ => 0 - | DClass (_, n, _) => n + | DClass (_, n, _, _) => n | DExport _ => 0 | DTable (n1, _, n2, _) => Int.max (n1, n2) | DSequence (n1, _, n2) => Int.max (n1, n2) @@ -1002,8 +1009,8 @@ and maxNameSgi (sgi, _) = | SgiStr (_, n, sgn) => Int.max (n, maxNameSgn sgn) | SgiSgn (_, n, sgn) => Int.max (n, maxNameSgn sgn) | SgiConstraint _ => 0 - | SgiClassAbs (_, n) => n - | SgiClass (_, n, _) => n + | SgiClassAbs (_, n, _) => n + | SgiClass (_, n, _, _) => n end diff --git a/src/elaborate.sml b/src/elaborate.sml index d42175ce..05e08c81 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2059,24 +2059,26 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = ([(L'.SgiConstraint (c1', c2'), loc)], (env, denv, gs1 @ gs2 @ gs3)) end - | L.SgiClassAbs x => + | L.SgiClassAbs (x, k) => let - val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) - val (env, n) = E.pushCNamed env x k NONE + val k = elabKind k + val k' = (L'.KArrow (k, (L'.KType, loc)), loc) + val (env, n) = E.pushCNamed env x k' NONE val env = E.pushClass env n in - ([(L'.SgiClassAbs (x, n), loc)], (env, denv, [])) + ([(L'.SgiClassAbs (x, n, k), loc)], (env, denv, [])) end - | L.SgiClass (x, c) => + | L.SgiClass (x, k, c) => let - val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) + val k = elabKind k + val k' = (L'.KArrow (k, (L'.KType, loc)), loc) val (c', ck, gs) = elabCon (env, denv) c - val (env, n) = E.pushCNamed env x k (SOME c') + val (env, n) = E.pushCNamed env x k' (SOME c') val env = E.pushClass env n in - checkKind env c' ck k; - ([(L'.SgiClass (x, n, c'), loc)], (env, denv, [])) + checkKind env c' ck k'; + ([(L'.SgiClass (x, n, k, c'), loc)], (env, denv, [])) end and elabSgn (env, denv) (sgn, loc) = @@ -2140,13 +2142,13 @@ and elabSgn (env, denv) (sgn, loc) = (); (cons, vals, sgns, SS.add (strs, x))) | L'.SgiConstraint _ => (cons, vals, sgns, strs) - | L'.SgiClassAbs (x, _) => + | L'.SgiClassAbs (x, _, _) => (if SS.member (cons, x) then sgnError env (DuplicateCon (loc, x)) else (); (SS.add (cons, x), vals, sgns, strs)) - | L'.SgiClass (x, _, _) => + | L'.SgiClass (x, _, _, _) => (if SS.member (cons, x) then sgnError env (DuplicateCon (loc, x)) else @@ -2222,8 +2224,8 @@ fun selfify env {str, strs, sgn} = (L'.SgiCon (x, n, k, (L'.CModProj (str, strs, x), loc)), loc) | (L'.SgiDatatype (x, n, xs, xncs), loc) => (L'.SgiDatatypeImp (x, n, str, strs, x, xs, xncs), loc) - | (L'.SgiClassAbs (x, n), loc) => - (L'.SgiClass (x, n, (L'.CModProj (str, strs, x), loc)), loc) + | (L'.SgiClassAbs (x, n, k), loc) => + (L'.SgiClass (x, n, k, (L'.CModProj (str, strs, x), loc)), loc) | (L'.SgiStr (x, n, sgn), loc) => (L'.SgiStr (x, n, selfify env {str = str, strs = strs @ [x], sgn = sgn}), loc) | x => x) sgis), #2 sgn) @@ -2284,19 +2286,19 @@ fun dopen (env, denv) {str, strs, sgn} = (L'.DSgn (x, n, (L'.SgnProj (str, strs, x), loc)), loc) | L'.SgiConstraint (c1, c2) => (L'.DConstraint (c1, c2), loc) - | L'.SgiClassAbs (x, n) => + | L'.SgiClassAbs (x, n, k) => let - val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) + val k' = (L'.KArrow (k, (L'.KType, loc)), loc) val c = (L'.CModProj (str, strs, x), loc) in - (L'.DCon (x, n, k, c), loc) + (L'.DCon (x, n, k', c), loc) end - | L'.SgiClass (x, n, _) => + | L'.SgiClass (x, n, k, _) => let - val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) + val k' = (L'.KArrow (k, (L'.KType, loc)), loc) val c = (L'.CModProj (str, strs, x), loc) in - (L'.DCon (x, n, k, c), loc) + (L'.DCon (x, n, k', c), loc) end in (d, (E.declBinds env' d, denv')) @@ -2320,7 +2322,7 @@ fun sgiOfDecl (d, loc) = | L'.DExport _ => [] | L'.DTable (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (tableOf (), c), loc)), loc)] | L'.DSequence (tn, x, n) => [(L'.SgiVal (x, n, sequenceOf ()), loc)] - | L'.DClass (x, n, c) => [(L'.SgiClass (x, n, c), loc)] + | L'.DClass (x, n, k, c) => [(L'.SgiClass (x, n, k, c), loc)] | L'.DDatabase _ => [] | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] @@ -2418,14 +2420,14 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = in found (x', n1, k', SOME (L'.CModProj (m1, ms, s), loc)) end - | L'.SgiClassAbs (x', n1) => found (x', n1, - (L'.KArrow ((L'.KType, loc), - (L'.KType, loc)), loc), - NONE) - | L'.SgiClass (x', n1, c) => found (x', n1, - (L'.KArrow ((L'.KType, loc), - (L'.KType, loc)), loc), - SOME c) + | L'.SgiClassAbs (x', n1, k) => found (x', n1, + (L'.KArrow (k, + (L'.KType, loc)), loc), + NONE) + | L'.SgiClass (x', n1, k, c) => found (x', n1, + (L'.KArrow (k, + (L'.KType, loc)), loc), + SOME c) | _ => NONE end) @@ -2458,8 +2460,8 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = in case sgi1 of L'.SgiCon (x', n1, k1, c1) => found (x', n1, k1, c1) - | L'.SgiClass (x', n1, c1) => - found (x', n1, (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc), c1) + | L'.SgiClass (x', n1, k1, c1) => + found (x', n1, (L'.KArrow (k1, (L'.KType, loc)), loc), c1) | _ => NONE end) @@ -2632,13 +2634,17 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = NONE | _ => NONE) - | L'.SgiClassAbs (x, n2) => + | L'.SgiClassAbs (x, n2, k2) => seek (fn (env, sgi1All as (sgi1, _)) => let - fun found (x', n1, co) = + fun found (x', n1, k1, co) = if x = x' then let - val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) + val () = unifyKinds k1 k2 + handle KUnify (k1, k2, err) => + sgnError env (SgiWrongKind (sgi1All, k1, sgi2All, k2, err)) + + val k = (L'.KArrow (k1, (L'.KType, loc)), loc) val env = E.pushCNamedAs env x n1 k co in SOME (if n1 = n2 then @@ -2651,18 +2657,22 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = NONE in case sgi1 of - L'.SgiClassAbs (x', n1) => found (x', n1, NONE) - | L'.SgiClass (x', n1, c) => found (x', n1, SOME c) + L'.SgiClassAbs (x', n1, k1) => found (x', n1, k1, NONE) + | L'.SgiClass (x', n1, k1, c) => found (x', n1, k1, SOME c) | _ => NONE end) - | L'.SgiClass (x, n2, c2) => + | L'.SgiClass (x, n2, k2, c2) => seek (fn (env, sgi1All as (sgi1, _)) => let - val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) + val k = (L'.KArrow (k2, (L'.KType, loc)), loc) - fun found (x', n1, c1) = + fun found (x', n1, k1, c1) = if x = x' then let + val () = unifyKinds k1 k2 + handle KUnify (k1, k2, err) => + sgnError env (SgiWrongKind (sgi1All, k1, sgi2All, k2, err)) + fun good () = let val env = E.pushCNamedAs env x n2 k (SOME c2) @@ -2685,7 +2695,7 @@ fun subSgn (env, denv) sgn1 (sgn2 as (_, loc2)) = NONE in case sgi1 of - L'.SgiClass (x', n1, c1) => found (x', n1, c1) + L'.SgiClass (x', n1, k1, c1) => found (x', n1, k1, c1) | _ => NONE end) end @@ -2878,8 +2888,8 @@ fun wildifyStr env (str, sgn) = L.DCon (x, _, _) => ((#1 (SM.remove (neededC, x)), neededV) handle NotFound => needed) - | L.DClass (x, _) => ((#1 (SM.remove (neededC, x)), neededV) - handle NotFound => needed) + | 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 _ => (SM.empty, SS.empty) @@ -3286,15 +3296,16 @@ fun elabDecl (dAll as (d, loc), (env, denv, gs : constraint list)) = ([(L'.DSequence (!basis_r, x, n), loc)], (env, denv, gs)) end - | L.DClass (x, c) => + | L.DClass (x, k, c) => let - val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) + val k = elabKind k + val k' = (L'.KArrow (k, (L'.KType, loc)), loc) val (c', ck, gs') = elabCon (env, denv) c - val (env, n) = E.pushCNamed env x k (SOME c') + val (env, n) = E.pushCNamed env x k' (SOME c') val env = E.pushClass env n in - checkKind env c' ck k; - ([(L'.DClass (x, n, c'), loc)], (env, denv, enD gs' @ gs)) + checkKind env c' ck k'; + ([(L'.DClass (x, n, k, c'), loc)], (env, denv, enD gs' @ gs)) end | L.DDatabase s => ([(L'.DDatabase s, loc)], (env, denv, gs)) @@ -3408,29 +3419,25 @@ and elabStr (env, denv) (str, loc) = ((L'.SgiStr (x, n, sgn), loc) :: sgis, cons, vals, sgns, strs) end | L'.SgiConstraint _ => ((sgi, loc) :: sgis, cons, vals, sgns, strs) - | L'.SgiClassAbs (x, n) => + | L'.SgiClassAbs (x, n, k) => let - val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) - val (cons, x) = if SS.member (cons, x) then (cons, "?" ^ x) else (SS.add (cons, x), x) in - ((L'.SgiClassAbs (x, n), loc) :: sgis, cons, vals, sgns, strs) + ((L'.SgiClassAbs (x, n, k), loc) :: sgis, cons, vals, sgns, strs) end - | L'.SgiClass (x, n, c) => + | L'.SgiClass (x, n, k, c) => let - val k = (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc) - val (cons, x) = if SS.member (cons, x) then (cons, "?" ^ x) else (SS.add (cons, x), x) in - ((L'.SgiClass (x, n, c), loc) :: sgis, cons, vals, sgns, strs) + ((L'.SgiClass (x, n, k, c), loc) :: sgis, cons, vals, sgns, strs) end) ([], SS.empty, SS.empty, SS.empty, SS.empty) sgis diff --git a/src/explify.sml b/src/explify.sml index e3c22f20..a10037ef 100644 --- a/src/explify.sml +++ b/src/explify.sml @@ -139,9 +139,9 @@ fun explifySgi (sgi, loc) = | L.SgiStr (x, n, sgn) => SOME (L'.SgiStr (x, n, explifySgn sgn), loc) | L.SgiSgn (x, n, sgn) => SOME (L'.SgiSgn (x, n, explifySgn sgn), loc) | L.SgiConstraint _ => NONE - | L.SgiClassAbs (x, n) => SOME (L'.SgiConAbs (x, n, (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc)), loc) - | L.SgiClass (x, n, c) => SOME (L'.SgiCon (x, n, (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc), - explifyCon c), loc) + | L.SgiClassAbs (x, n, k) => SOME (L'.SgiConAbs (x, n, (L'.KArrow (explifyKind k, (L'.KType, loc)), loc)), loc) + | L.SgiClass (x, n, k, c) => SOME (L'.SgiCon (x, n, (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), + explifyCon c), loc) and explifySgn (sgn, loc) = case sgn of @@ -172,8 +172,8 @@ fun explifyDecl (d, loc : EM.span) = | L.DExport (en, sgn, str) => SOME (L'.DExport (en, explifySgn sgn, explifyStr str), loc) | L.DTable (nt, x, n, c) => SOME (L'.DTable (nt, x, n, explifyCon c), loc) | L.DSequence (nt, x, n) => SOME (L'.DSequence (nt, x, n), loc) - | L.DClass (x, n, c) => SOME (L'.DCon (x, n, - (L'.KArrow ((L'.KType, loc), (L'.KType, loc)), loc), explifyCon c), loc) + | L.DClass (x, n, k, c) => SOME (L'.DCon (x, n, + (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), explifyCon c), loc) | L.DDatabase s => SOME (L'.DDatabase s, loc) | L.DCookie (nt, x, n, c) => SOME (L'.DCookie (nt, x, n, explifyCon c), loc) diff --git a/src/source.sml b/src/source.sml index 7685bb2f..a5c86f66 100644 --- a/src/source.sml +++ b/src/source.sml @@ -81,8 +81,8 @@ datatype sgn_item' = | SgiSgn of string * sgn | SgiInclude of sgn | SgiConstraint of con * con - | SgiClassAbs of string - | SgiClass of string * con + | SgiClassAbs of string * kind + | SgiClass of string * kind * con and sgn' = SgnConst of sgn_item list @@ -154,7 +154,7 @@ datatype decl' = | DExport of str | DTable of string * con | DSequence of string - | DClass of string * con + | DClass of string * kind * con | DDatabase of string | DCookie of string * con diff --git a/src/source_print.sml b/src/source_print.sml index 77f2d749..d6568efe 100644 --- a/src/source_print.sml +++ b/src/source_print.sml @@ -413,17 +413,25 @@ fun p_sgn_item (sgi, _) = string "~", space, p_con c2] - | SgiClassAbs x => box [string "class", - space, - string x] - | SgiClass (x, c) => box [string "class", - space, - string x, - space, - string "=", - space, - p_con c] - + | SgiClassAbs (x, k) => box [string "class", + space, + string x, + space, + string "::", + space, + p_kind k] + | SgiClass (x, k, c) => box [string "class", + space, + string x, + space, + string "::", + space, + p_kind k, + space, + string "=", + space, + p_con c] + and p_sgn (sgn, _) = case sgn of SgnConst sgis => box [string "sig", @@ -562,13 +570,13 @@ fun p_decl ((d, _) : decl) = | DSequence x => box [string "sequence", space, string x] - | DClass (x, c) => box [string "class", - space, - string x, - space, - string "=", - space, - p_con c] + | DClass (x, k, c) => box [string "class", + space, + string x, + space, + string "=", + space, + p_con c] | DDatabase s => box [string "database", space, diff --git a/src/urweb.grm b/src/urweb.grm index 7798b018..5f2c0575 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -410,13 +410,24 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let | EXPORT spath ([(DExport spath, s (EXPORTleft, spathright))]) | TABLE SYMBOL COLON cexp ([(DTable (SYMBOL, entable cexp), s (TABLEleft, cexpright))]) | SEQUENCE SYMBOL ([(DSequence SYMBOL, s (SEQUENCEleft, SYMBOLright))]) - | CLASS SYMBOL EQ cexp ([(DClass (SYMBOL, cexp), s (CLASSleft, cexpright))]) + | CLASS SYMBOL EQ cexp (let + val loc = s (CLASSleft, cexpright) + in + [(DClass (SYMBOL, (KWild, loc), cexp), loc)] + end) + | CLASS SYMBOL DCOLON kind EQ cexp ([(DClass (SYMBOL, kind, cexp), s (CLASSleft, cexpright))]) | CLASS SYMBOL SYMBOL EQ cexp (let val loc = s (CLASSleft, cexpright) - val k = (KType, loc) + val k = (KWild, loc) val c = (CAbs (SYMBOL2, SOME k, cexp), loc) in - [(DClass (SYMBOL1, c), s (CLASSleft, cexpright))] + [(DClass (SYMBOL1, k, c), s (CLASSleft, cexpright))] + end) + | CLASS SYMBOL LPAREN SYMBOL DCOLON kind RPAREN EQ cexp (let + val loc = s (CLASSleft, cexpright) + val c = (CAbs (SYMBOL2, SOME kind, cexp), loc) + in + [(DClass (SYMBOL1, kind, c), s (CLASSleft, cexpright))] end) | COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))]) @@ -501,14 +512,38 @@ sgi : CON SYMBOL DCOLON kind (SgiConAbs (SYMBOL, kind), s (CONleft, k in (SgiVal (SYMBOL, t), loc) end) - | CLASS SYMBOL (SgiClassAbs SYMBOL, s (CLASSleft, SYMBOLright)) - | CLASS SYMBOL EQ cexp (SgiClass (SYMBOL, cexp), s (CLASSleft, cexpright)) + | CLASS SYMBOL (let + val loc = s (CLASSleft, SYMBOLright) + in + (SgiClassAbs (SYMBOL, (KWild, loc)), loc) + end) + | CLASS SYMBOL DCOLON kind (let + val loc = s (CLASSleft, kindright) + in + (SgiClassAbs (SYMBOL, kind), loc) + end) + | CLASS SYMBOL EQ cexp (let + val loc = s (CLASSleft, cexpright) + in + (SgiClass (SYMBOL, (KWild, loc), cexp), loc) + end) + | CLASS SYMBOL DCOLON kind EQ cexp (let + val loc = s (CLASSleft, cexpright) + in + (SgiClass (SYMBOL, kind, cexp), loc) + end) | CLASS SYMBOL SYMBOL EQ cexp (let val loc = s (CLASSleft, cexpright) - val k = (KType, loc) + val k = (KWild, loc) val c = (CAbs (SYMBOL2, SOME k, cexp), loc) in - (SgiClass (SYMBOL1, c), s (CLASSleft, cexpright)) + (SgiClass (SYMBOL1, k, c), s (CLASSleft, cexpright)) + end) + | CLASS SYMBOL LPAREN SYMBOL DCOLON kind RPAREN EQ cexp (let + val loc = s (CLASSleft, cexpright) + val c = (CAbs (SYMBOL2, SOME kind, cexp), loc) + in + (SgiClass (SYMBOL1, kind, c), s (CLASSleft, cexpright)) end) | COOKIE SYMBOL COLON cexp (let val loc = s (COOKIEleft, cexpright) -- 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(-) 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 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 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 a08075494d9c16a349215fbcaefa3e1d14d2e0f9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 20 Dec 2008 14:19:21 -0500 Subject: Start of JsComp --- src/compiler.sig | 2 + src/compiler.sml | 9 +- src/jscomp.sig | 32 +++++ src/jscomp.sml | 344 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/mono_env.sig | 1 + src/mono_env.sml | 11 ++ src/mono_opt.sml | 5 - src/mono_util.sig | 11 ++ src/mono_util.sml | 15 +++ src/prim.sig | 2 + src/prim.sml | 6 + src/sources | 3 + tests/alert.ur | 2 +- 13 files changed, 436 insertions(+), 7 deletions(-) create mode 100644 src/jscomp.sig create mode 100644 src/jscomp.sml diff --git a/src/compiler.sig b/src/compiler.sig index 59ad32be..1f1f4973 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -75,6 +75,7 @@ signature COMPILER = sig val untangle : (Mono.file, Mono.file) phase val mono_reduce : (Mono.file, Mono.file) phase val mono_shake : (Mono.file, Mono.file) phase + val jscomp : (Mono.file, Mono.file) phase val fuse : (Mono.file, Mono.file) phase val pathcheck : (Mono.file, Mono.file) phase val cjrize : (Mono.file, Cjr.file) phase @@ -101,6 +102,7 @@ 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 toFuse : (string, Mono.file) transform val toUntangle2 : (string, Mono.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 0ff4ee6a..ecee1065 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -511,7 +511,14 @@ 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 toMono_opt2 = transform mono_opt "mono_opt2" o toJscomp val fuse = { func = Fuse.fuse, diff --git a/src/jscomp.sig b/src/jscomp.sig new file mode 100644 index 00000000..929c507d --- /dev/null +++ b/src/jscomp.sig @@ -0,0 +1,32 @@ +(* 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. + *) + +signature JSCOMP = sig + + val process : Mono.file -> Mono.file + +end diff --git a/src/jscomp.sml b/src/jscomp.sml new file mode 100644 index 00000000..0dd7882a --- /dev/null +++ b/src/jscomp.sml @@ -0,0 +1,344 @@ +(* 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. + *) + +structure JsComp :> JSCOMP = struct + +open Mono + +structure EM = ErrorMsg +structure E = MonoEnv +structure U = MonoUtil + +type state = { + decls : decl list, + script : string +} + +fun varDepth (e, _) = + case e of + EPrim _ => 0 + | ERel _ => 0 + | ENamed _ => 0 + | ECon (_, _, NONE) => 0 + | ECon (_, _, SOME e) => varDepth e + | ENone _ => 0 + | ESome (_, e) => varDepth e + | EFfi _ => 0 + | EFfiApp (_, _, es) => foldl Int.max 0 (map varDepth es) + | EApp (e1, e2) => Int.max (varDepth e1, varDepth e2) + | EAbs _ => 0 + | EUnop (_, e) => varDepth e + | EBinop (_, e1, e2) => Int.max (varDepth e1, varDepth e2) + | ERecord xes => foldl Int.max 0 (map (fn (_, e, _) => varDepth e) xes) + | EField (e, _) => varDepth e + | ECase (e, pes, _) => + foldl Int.max (varDepth e) + (map (fn (p, e) => E.patBindsN p + varDepth e) pes) + | EStrcat (e1, e2) => Int.max (varDepth e1, varDepth e2) + | EError (e, _) => varDepth e + | EWrite e => varDepth e + | ESeq (e1, e2) => Int.max (varDepth e1, varDepth e2) + | ELet (_, _, e1, e2) => Int.max (varDepth e1, 1 + varDepth e2) + | EClosure _ => 0 + | EQuery _ => 0 + | EDml _ => 0 + | ENextval _ => 0 + | EUnurlify _ => 0 + | EJavaScript _ => 0 + +fun jsExp inAttr outer = + let + val len = length outer + + fun jsE inner (e as (_, loc), st) = + let + fun str s = (EPrim (Prim.String s), loc) + + fun var n = Int.toString (len + inner - n - 1) + + fun patCon pc = + case pc of + 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 + TOption _ => true + | _ => false + + fun unsupported s = + (EM.errorAt loc (s ^ " in code to be compiled to JavaScript"); + (str "ERROR", st)) + in + case #1 e of + EPrim (Prim.String s) => + (str ("\"" + ^ String.translate (fn #"'" => + if inAttr then + "\\047" + else + "'" + | #"<" => + if inAttr then + "<" + else + "\\074" + | #"\\" => "\\\\" + | ch => String.str ch) s + ^ "\""), st) + | EPrim p => (str (Prim.toString p), st) + | ERel n => + if n < inner then + (str ("uwr" ^ var n), st) + else + (str ("uwo" ^ var n), st) + | ENamed _ => raise Fail "Named" + | ECon (_, pc, NONE) => (patCon pc, st) + | ECon (_, pc, SOME e) => + let + val (s, st) = jsE inner (e, st) + in + (strcat [str "{n:", + patCon pc, + str ",v:", + s, + str "}"], st) + end + | ENone _ => (str "null", st) + | ESome (t, e) => + let + val (e, st) = jsE inner (e, st) + in + (if isNullable t then + strcat [str "{v:", e, str "}"] + else + e, st) + end + + | EFfi (_, s) => (str s, st) + | EFfiApp (_, s, []) => (str (s ^ "()"), st) + | EFfiApp (_, s, [e]) => + let + val (e, st) = jsE inner (e, st) + + in + (strcat [str (s ^ "("), + e, + str ")"], st) + end + | EFfiApp (_, s, 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 (s ^ "(") + :: e + :: es + @ [str ")"]), st) + end + + | EApp (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [e1, str "(", e2, str ")"], st) + end + | EAbs (_, _, _, e) => + let + val locals = List.tabulate + (varDepth e, + fn i => str ("var uwr" ^ Int.toString (len + inner + i) ^ ";")) + val (e, st) = jsE (inner + 1) (e, st) + in + (strcat (str ("function(uwr" + ^ Int.toString (len + inner) + ^ "){") + :: locals + @ [str "return ", + e, + str "}"]), + st) + end + + | EUnop (s, e) => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str ("(" ^ s), + e, + str ")"], + st) + end + | EBinop (s, e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "(", + e1, + str s, + e2, + str ")"], + st) + end + + | ERecord [] => (str "null", st) + | ERecord [(x, e, _)] => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "{uw_x:", e, str "}"], st) + end + | ERecord ((x, e, _) :: xes) => + let + val (e, st) = jsE inner (e, st) + + val (es, st) = + foldr (fn ((x, e, _), (es, st)) => + let + val (e, st) = jsE inner (e, st) + in + (str (",uw_" ^ x ^ ":") + :: e + :: es, + st) + end) + ([str "}"], st) xes + in + (strcat (str ("{uw_" ^ x ^ ":") + :: e + :: es), + st) + end + | EField (e, x) => + let + val (e, st) = jsE inner (e, st) + in + (strcat [e, + str ("." ^ x)], st) + end + + | ECase _ => raise Fail "Jscomp: ECase" + + | EStrcat (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "(", e1, str "+", e2, str ")"], st) + end + + | EError (e, _) => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "alert(\"ERROR: \"+", e, str ")"], + st) + end + + | EWrite _ => unsupported "EWrite" + + | ESeq (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "(", e1, str ",", e2, str ")"], st) + end + | ELet (_, _, e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE (inner + 1) (e2, st) + in + (strcat [str ("(uwr" ^ Int.toString (len + inner) ^ "="), + e1, + str ",", + e2, + str ")"], st) + end + + | EClosure _ => unsupported "EClosure" + | EQuery _ => unsupported "Query" + | EDml _ => unsupported "DML" + | ENextval _ => unsupported "Nextval" + | EUnurlify _ => unsupported "EUnurlify" + | EJavaScript _ => unsupported "Nested JavaScript" + end + in + jsE + end + +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), + decl = fn (_, e, st) => (e, st), + bind = fn (env, U.Decl.RelE (_, t)) => t :: env + | (env, _) => env} + [] + +fun process file = + let + fun doDecl (d, st) = + let + val (d, st) = decl st d + in + (List.revAppend (#decls st, [d]), + {decls = [], + script = #script st}) + end + + val (ds, st) = ListUtil.foldlMapConcat doDecl + {decls = [], + script = ""} + file + in + ds + end + +end diff --git a/src/mono_env.sig b/src/mono_env.sig index cb6f2352..c59596ae 100644 --- a/src/mono_env.sig +++ b/src/mono_env.sig @@ -47,5 +47,6 @@ signature MONO_ENV = sig val declBinds : env -> Mono.decl -> env val patBinds : env -> Mono.pat -> env + val patBindsN : Mono.pat -> int end diff --git a/src/mono_env.sml b/src/mono_env.sml index 47ffd28d..cce4a4c4 100644 --- a/src/mono_env.sml +++ b/src/mono_env.sml @@ -122,4 +122,15 @@ fun patBinds env (p, loc) = | PNone _ => env | PSome (_, p) => patBinds env p +fun patBindsN (p, loc) = + case p of + PWild => 0 + | PVar _ => 1 + | PPrim _ => 0 + | PCon (_, _, NONE) => 0 + | PCon (_, _, SOME p) => patBindsN p + | PRecord xps => foldl (fn ((_, p, _), count) => count + patBindsN p) 0 xps + | PNone _ => 0 + | PSome (_, p) => patBindsN p + end diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 7f83c003..6c0e6e21 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -360,11 +360,6 @@ 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_util.sig b/src/mono_util.sig index 32a83855..2a96211a 100644 --- a/src/mono_util.sig +++ b/src/mono_util.sig @@ -71,6 +71,11 @@ structure Exp : sig val exists : {typ : Mono.typ' -> bool, exp : Mono.exp' -> bool} -> Mono.exp -> bool + + val foldB : {typ : Mono.typ' * 'state -> 'state, + exp : 'context * Mono.exp' * 'state -> 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Mono.exp -> 'state end structure Decl : sig @@ -95,6 +100,12 @@ structure Decl : sig exp : Mono.exp' -> Mono.exp', decl : Mono.decl' -> Mono.decl'} -> Mono.decl -> Mono.decl + + val foldMapB : {typ : Mono.typ' * 'state -> Mono.typ' * 'state, + exp : 'context * Mono.exp' * 'state -> Mono.exp' * 'state, + decl : 'context * Mono.decl' * 'state -> Mono.decl' * 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Mono.decl -> Mono.decl * 'state end structure File : sig diff --git a/src/mono_util.sml b/src/mono_util.sml index 18b5c948..ebc30984 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -357,6 +357,13 @@ fun exists {typ, exp} k = S.Return _ => true | S.Continue _ => false +fun foldB {typ, exp, bind} ctx s e = + case mapfoldB {typ = fn t => fn s => S.Continue (t, typ (t, s)), + exp = fn ctx => fn e => fn s => S.Continue (e, exp (ctx, e, s)), + bind = bind} ctx e s of + S.Continue (_, s) => s + | S.Return _ => raise Fail "MonoUtil.Exp.foldB: Impossible" + end structure Decl = struct @@ -433,6 +440,14 @@ fun map {typ, exp, decl} e = S.Return () => raise Fail "MonoUtil.Decl.map: Impossible" | S.Continue (e, ()) => e +fun foldMapB {typ, exp, decl, bind} ctx s d = + case mapfoldB {typ = fn c => fn s => S.Continue (typ (c, s)), + exp = fn ctx => fn e => fn s => S.Continue (exp (ctx, e, s)), + decl = fn ctx => fn d => fn s => S.Continue (decl (ctx, d, s)), + bind = bind} ctx d s of + S.Continue v => v + | S.Return _ => raise Fail "MonoUtil.Decl.foldMapB: Impossible" + end structure File = struct diff --git a/src/prim.sig b/src/prim.sig index 3083a26e..54625379 100644 --- a/src/prim.sig +++ b/src/prim.sig @@ -38,4 +38,6 @@ signature PRIM = sig val equal : t * t -> bool val compare : t * t -> order + val toString : t -> string + end diff --git a/src/prim.sml b/src/prim.sml index daf666e8..468b28d5 100644 --- a/src/prim.sml +++ b/src/prim.sml @@ -53,6 +53,12 @@ fun float2s n = else Real64.toString n +fun toString t = + case t of + Int n => int2s n + | Float n => float2s n + | String s => s + fun p_t_GCC t = case t of Int n => string (int2s n) diff --git a/src/sources b/src/sources index 6972dc36..05b1cc54 100644 --- a/src/sources +++ b/src/sources @@ -137,6 +137,9 @@ untangle.sml mono_shake.sig mono_shake.sml +jscomp.sig +jscomp.sml + pathcheck.sig pathcheck.sml diff --git a/tests/alert.ur b/tests/alert.ur index 7b2eaacf..3fe68d75 100644 --- a/tests/alert.ur +++ b/tests/alert.ur @@ -1,3 +1,3 @@ fun main () : transaction page = return - Click Me! + Click Me! -- 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 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 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 65428eeb2cba9807043188bfddf5fbfd1bf9296b Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 20 Dec 2008 18:24:12 -0500 Subject: Typo report from megacz --- doc/manual.tex | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/manual.tex b/doc/manual.tex index 930fd9f9..af905574 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -1017,7 +1017,7 @@ Nonetheless, the unification engine tends to do reasonably well. Unlike in ML, \subsection{Unifying Record Types} -The type inference engine tries to take advantage of the algebraic rules governing type-level records, as shown in Section \ref{definitional}. When two constructors of record kind are unified, they are reduce to normal forms, with like terms crossed off from each normal form until, hopefully, nothing remains. This cannot be complete, with the inclusion of unification variables. The type-checker can help you understand what goes wrong when the process fails, as it outputs the unmatched remainders of the two normal forms. +The type inference engine tries to take advantage of the algebraic rules governing type-level records, as shown in Section \ref{definitional}. When two constructors of record kind are unified, they are reduced to normal forms, with like terms crossed off from each normal form until, hopefully, nothing remains. This cannot be complete, with the inclusion of unification variables. The type-checker can help you understand what goes wrong when the process fails, as it outputs the unmatched remainders of the two normal forms. \subsection{\label{typeclasses}Type Classes} -- 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(-) 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 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(-) 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 9030684acadec34adb8f08547dffe250ff4449d6 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 24 Dec 2008 10:48:31 -0500 Subject: More manual bug reports from megacz --- doc/manual.tex | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/doc/manual.tex b/doc/manual.tex index af905574..0e756426 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -435,11 +435,11 @@ $$\infer{\Gamma \vdash [\overline{c_i = c'_i}] :: \{\kappa\}}{ $$\infer{\Gamma \vdash \mt{fold} :: ((\mt{Name} \to \kappa_1 \to \kappa_2 \to \kappa_2) \to \kappa_2 \to \{\kappa_1\} \to \kappa_2}{}$$ -$$\infer{\Gamma \vdash (\overline c) :: (k_1 \times \ldots \times k_n)}{ - \forall i: \Gamma \vdash c_i :: k_i +$$\infer{\Gamma \vdash (\overline c) :: (\kappa_1 \times \ldots \times \kappa_n)}{ + \forall i: \Gamma \vdash c_i :: \kappa_i } -\quad \infer{\Gamma \vdash c.i :: k_i}{ - \Gamma \vdash c :: (k_1 \times \ldots \times k_n) +\quad \infer{\Gamma \vdash c.i :: \kappa_i}{ + \Gamma \vdash c :: (\kappa_1 \times \ldots \times \kappa_n) }$$ $$\infer{\Gamma \vdash \lambda [c_1 \sim c_2] \Rightarrow c :: \kappa}{ @@ -584,6 +584,7 @@ $$\infer{\Gamma \vdash \{\overline{c = e}\} : \{\overline{c : \tau}\}}{ \quad \infer{\Gamma \vdash e_1 \rc e_2 : \$(c_1 \rc c_2)}{ \Gamma \vdash e_1 : \$c_1 & \Gamma \vdash e_2 : \$c_2 + & \Gamma \vdash c_1 \sim c_2 }$$ $$\infer{\Gamma \vdash e \rcut c : \$c'}{ @@ -609,7 +610,7 @@ $$\infer{\Gamma \vdash \mt{let} \; \overline{ed} \; \mt{in} \; e \; \mt{end} : \ & \Gamma_i \vdash e_i : \tau }$$ -$$\infer{\Gamma \vdash [c_1 \sim c_2] \Rightarrow e : [c_1 \sim c_2] \Rightarrow \tau}{ +$$\infer{\Gamma \vdash \lambda [c_1 \sim c_2] \Rightarrow e : \lambda [c_1 \sim c_2] \Rightarrow \tau}{ \Gamma \vdash c_1 :: \{\kappa\} & \Gamma \vdash c_2 :: \{\kappa\} & \Gamma, c_1 \sim c_2 \vdash e : \tau -- 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(+) 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 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(-) 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 be73a31fb83c7da398322f6e92e94a7297212b7c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 30 Dec 2008 15:53:04 -0500 Subject: Propagated a source change into a dynamic document element --- jslib/urweb.js | 15 +++-- src/jscomp.sml | 18 +++-- src/mono_reduce.sml | 184 ++++++++++++++++++++++++++++------------------------ tests/reactive3.ur | 7 ++ tests/reactive3.urp | 3 + 5 files changed, 130 insertions(+), 97 deletions(-) create mode 100644 tests/reactive3.ur create mode 100644 tests/reactive3.urp diff --git a/jslib/urweb.js b/jslib/urweb.js index eab67626..86c3808c 100644 --- a/jslib/urweb.js +++ b/jslib/urweb.js @@ -1,11 +1,18 @@ -function sc(v) { return {v : v} } +function callAll(ls) { + for (; ls; ls = ls.next) + ls.v(); +} + +function sc(v) { return {v : v, h : null} } +function sv(s, v) { s.v = v; callAll(s.h); } -function ss(s) { return {v : s.v} } -function sr(v) { return {v : v} } -function sb(x,y) { return {v : y(x.v).v} } +function ss(s) { return s } +function sr(v) { return {v : v, h : null} } +function sb(x,y) { return {v : y(x.v).v, h : null} } function dyn(s) { var x = document.createElement("span"); x.innerHTML = s.v; document.body.appendChild(x); + s.h = { n : s.h, v : function() { x.innerHTML = s.v } }; } diff --git a/src/jscomp.sml b/src/jscomp.sml index a4e3dd35..bc407db8 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -35,7 +35,8 @@ structure U = MonoUtil val funcs = [(("Basis", "alert"), "alert"), (("Basis", "htmlifyString"), "escape"), - (("Basis", "new_client_source"), "sc")] + (("Basis", "new_client_source"), "sc"), + (("Basis", "set_client_source"), "sv")] structure FM = BinaryMapFn(struct type ord_key = string * string @@ -94,7 +95,7 @@ fun strcat loc es = | [x] => x | x :: es' => (EStrcat (x, strcat loc es'), loc) -fun jsExp mode outer = +fun jsExp mode skip outer = let val len = length outer @@ -126,7 +127,10 @@ fun jsExp mode outer = 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") in case #1 e of @@ -154,7 +158,7 @@ fun jsExp mode outer = let val n = n - inner in - (quoteExp (List.nth (outer, n)) (ERel n, loc), st) + (quoteExp (List.nth (outer, n)) (ERel (n - skip), loc), st) end | ENamed _ => raise Fail "Named" | ECon (_, pc, NONE) => (patCon pc, st) @@ -403,7 +407,7 @@ val decl : state -> decl -> decl * state = U.Decl.foldMapB {typ = fn x => x, exp = fn (env, e, st) => let - fun doCode m env orig e = + fun doCode m skip env orig e = let val len = length env fun str s = (EPrim (Prim.String s), #2 e) @@ -411,14 +415,14 @@ val decl : state -> decl -> decl * state = val locals = List.tabulate (varDepth e, fn i => str ("var uwr" ^ Int.toString (len + i) ^ ";")) - val (e, st) = jsExp m env 0 (e, st) + val (e, st) = jsExp m skip env 0 (e, st) in (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st) end in case e of - EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => doCode m (t :: env) orig e - | EJavaScript (m, e, _) => doCode m env e e + EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => doCode m 1 (t :: env) orig e + | EJavaScript (m, e, _) => doCode m 0 env e e | _ => (e, st) end, decl = fn (_, e, st) => (e, st), diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index c96f97cf..0117623f 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -56,6 +56,7 @@ fun impure (e, _) = | EFfiApp ("Basis", "set_cookie", _) => true | EFfiApp ("Basis", "new_client_source", _) => true | EFfiApp ("Basis", "set_client_source", _) => true + | EFfiApp ("Basis", "alert", _) => true | EFfiApp _ => false | EApp ((EFfi _, _), _) => false | EApp _ => true @@ -253,92 +254,103 @@ fun reduce file = IM.empty file fun summarize d (e, _) = - case e of - EPrim _ => [] - | ERel n => if n = d then [UseRel] else [] - | ENamed _ => [] - | ECon (_, _, NONE) => [] - | ECon (_, _, SOME e) => summarize d e - | ENone _ => [] - | ESome (_, e) => summarize d e - | 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 _ => - let - 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, - if n = d then - [UseRel, Unsure] - else - [Unsure]) - | EApp (f, x) => - unravel (#1 f, summarize d x @ ls) - | _ => [Unsure] - in - unravel (e, []) - end - - | 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 - | EJavaScript (_, e, _) => summarize d e - | ESignalReturn e => summarize d e - | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 - | ESignalSource e => summarize d e + let + val s = + case e of + EPrim _ => [] + | ERel n => if n = d then [UseRel] else [] + | ENamed _ => [] + | ECon (_, _, NONE) => [] + | ECon (_, _, SOME e) => summarize d e + | ENone _ => [] + | ESome (_, e) => summarize d e + | EFfi _ => [] + | EFfiApp ("Basis", "set_cookie", es) => List.concat (map (summarize d) es) @ [Unsure] + | EFfiApp ("Basis", "new_client_source", es) => List.concat (map (summarize d) es) @ [Unsure] + | EFfiApp ("Basis", "set_client_source", es) => List.concat (map (summarize d) es) @ [Unsure] + | EFfiApp ("Basis", "alert", es) => List.concat (map (summarize d) es) @ [Unsure] + | EFfiApp (_, _, es) => List.concat (map (summarize d) es) + | EApp ((EFfi _, _), e) => summarize d e + | EApp _ => + let + 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, + if n = d then + [UseRel, Unsure] + else + [Unsure]) + | EApp (f, x) => + unravel (#1 f, summarize d x @ ls) + | _ => [Unsure] + in + unravel (e, []) + end + + | EAbs (_, _, _, e) => List.filter (fn UseRel => true + | _ => false) (summarize (d + 1) e) + + | 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 + | EJavaScript (_, e, _) => summarize d e + | ESignalReturn e => summarize d e + | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 + | ESignalSource e => summarize d e + in + (*Print.prefaces "Summarize" + [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)), + ("d", Print.PD.string (Int.toString d)), + ("s", p_events s)];*) + s + end fun exp env e = let diff --git a/tests/reactive3.ur b/tests/reactive3.ur new file mode 100644 index 00000000..c12455c5 --- /dev/null +++ b/tests/reactive3.ur @@ -0,0 +1,7 @@ +fun main () : transaction page = + x <- source TEST; + return + +
    + CHANGEUP    }>Oh My +     diff --git a/tests/reactive3.urp b/tests/reactive3.urp new file mode 100644 index 00000000..8a95bc84 --- /dev/null +++ b/tests/reactive3.urp @@ -0,0 +1,3 @@ +debug + +reactive3 -- cgit v1.2.3 From 7f3851104f9fdefdd09d8e9a0f600968175589e0 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 30 Dec 2008 16:08:25 -0500 Subject: Propagating a change through a bind --- jslib/urweb.js | 36 ++++++++++++++++++++++++++++++------ tests/reactive4.ur | 7 +++++++ tests/reactive4.urp | 3 +++ 3 files changed, 40 insertions(+), 6 deletions(-) create mode 100644 tests/reactive4.ur create mode 100644 tests/reactive4.urp diff --git a/jslib/urweb.js b/jslib/urweb.js index 86c3808c..508f4318 100644 --- a/jslib/urweb.js +++ b/jslib/urweb.js @@ -1,18 +1,42 @@ +function cons(v, ls) { + return { n : ls, v : v }; +} function callAll(ls) { for (; ls; ls = ls.next) ls.v(); } -function sc(v) { return {v : v, h : null} } -function sv(s, v) { s.v = v; callAll(s.h); } +function sc(v) { + return {v : v, h : null}; +} +function sv(s, v) { + s.v = v; + callAll(s.h); +} -function ss(s) { return s } -function sr(v) { return {v : v, h : null} } -function sb(x,y) { return {v : y(x.v).v, h : null} } +function ss(s) { + return s; +} +function sr(v) { + return {v : v, h : null}; +} +function sb(x,y) { + var z = y(x.v); + var s = {v : z.v, h : null}; + + function reZ() { + z.h = cons(function() { s.v = z.v; callAll(s.h); }, z.h); + } + + x.h = cons(function() { z = y(x.v); reZ(); s.v = z.v; callAll(s.h); }, x.h); + reZ(); + + return s; +} function dyn(s) { var x = document.createElement("span"); x.innerHTML = s.v; document.body.appendChild(x); - s.h = { n : s.h, v : function() { x.innerHTML = s.v } }; + s.h = cons(function() { x.innerHTML = s.v }, s.h); } diff --git a/tests/reactive4.ur b/tests/reactive4.ur new file mode 100644 index 00000000..b5278a63 --- /dev/null +++ b/tests/reactive4.ur @@ -0,0 +1,7 @@ +fun main () : transaction page = + x <- source TEST; + return + !{y}?}/> +
    + CHANGEUP    }>Oh My +     diff --git a/tests/reactive4.urp b/tests/reactive4.urp new file mode 100644 index 00000000..e32cf7a7 --- /dev/null +++ b/tests/reactive4.urp @@ -0,0 +1,3 @@ +debug + +reactive4 -- cgit v1.2.3 From c25af86ae9310055dd594f6330e39f93c9f24cb7 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 30 Dec 2008 16:11:29 -0500 Subject: Double-bind works --- tests/reactive5.ur | 9 +++++++++ tests/reactive5.urp | 3 +++ 2 files changed, 12 insertions(+) create mode 100644 tests/reactive5.ur create mode 100644 tests/reactive5.urp diff --git a/tests/reactive5.ur b/tests/reactive5.ur new file mode 100644 index 00000000..01c63eae --- /dev/null +++ b/tests/reactive5.ur @@ -0,0 +1,9 @@ +fun main () : transaction page = + x <- source A; + y <- source B; + return + {x}, {y}}/> +
    + C    }>Change x
    + D    }>Change y
    +     diff --git a/tests/reactive5.urp b/tests/reactive5.urp new file mode 100644 index 00000000..27231d3d --- /dev/null +++ b/tests/reactive5.urp @@ -0,0 +1,3 @@ +debug + +reactive5 -- cgit v1.2.3 From 62e9d88be744f971152166280d522e78f4ddb574 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 1 Jan 2009 10:08:22 -0500 Subject: Source containing an int --- jslib/urweb.js | 2 ++ src/jscomp.sml | 1 + src/prim.sml | 8 +++++++- tests/stypes.ur | 5 +++++ tests/stypes.urp | 3 +++ 5 files changed, 18 insertions(+), 1 deletion(-) create mode 100644 tests/stypes.ur create mode 100644 tests/stypes.urp diff --git a/jslib/urweb.js b/jslib/urweb.js index 508f4318..e661a739 100644 --- a/jslib/urweb.js +++ b/jslib/urweb.js @@ -40,3 +40,5 @@ function dyn(s) { document.body.appendChild(x); s.h = cons(function() { x.innerHTML = s.v }, s.h); } + +function ts(x) { return x.toString() } diff --git a/src/jscomp.sml b/src/jscomp.sml index bc407db8..9a67e286 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -34,6 +34,7 @@ structure E = MonoEnv structure U = MonoUtil val funcs = [(("Basis", "alert"), "alert"), + (("Basis", "htmlifyInt"), "ts"), (("Basis", "htmlifyString"), "escape"), (("Basis", "new_client_source"), "sc"), (("Basis", "set_client_source"), "sv")] diff --git a/src/prim.sml b/src/prim.sml index 468b28d5..95df6e02 100644 --- a/src/prim.sml +++ b/src/prim.sml @@ -47,6 +47,12 @@ fun int2s n = else Int64.toString n ^ "LL" +fun int2s' n = + if Int64.compare (n, Int64.fromInt 0) = LESS then + "-" ^ Int64.toString (Int64.~ n) + else + Int64.toString n + fun float2s n = if Real64.compare (n, Real64.fromInt 0) = LESS then "-" ^ Real64.toString (Real64.~ n) @@ -55,7 +61,7 @@ fun float2s n = fun toString t = case t of - Int n => int2s n + Int n => int2s' n | Float n => float2s n | String s => s diff --git a/tests/stypes.ur b/tests/stypes.ur new file mode 100644 index 00000000..6368d5c9 --- /dev/null +++ b/tests/stypes.ur @@ -0,0 +1,5 @@ +fun main () : transaction page = + sInt <- source 0; + return + {[n]}}/> Change
    +     diff --git a/tests/stypes.urp b/tests/stypes.urp new file mode 100644 index 00000000..353ea9e6 --- /dev/null +++ b/tests/stypes.urp @@ -0,0 +1,3 @@ +debug + +stypes -- cgit v1.2.3 From bad5b1a5635b3db83b4178c200e9a83d49ffc2d7 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 1 Jan 2009 10:18:20 -0500 Subject: Reactive computation with more base types and records --- src/jscomp.sml | 22 +++++++++++----------- tests/stypes.ur | 11 ++++++++++- 2 files changed, 21 insertions(+), 12 deletions(-) diff --git a/src/jscomp.sml b/src/jscomp.sml index 9a67e286..c6299f83 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -34,6 +34,7 @@ structure E = MonoEnv structure U = MonoUtil val funcs = [(("Basis", "alert"), "alert"), + (("Basis", "htmlifyFloat"), "ts"), (("Basis", "htmlifyInt"), "ts"), (("Basis", "htmlifyString"), "escape"), (("Basis", "new_client_source"), "sc"), @@ -111,11 +112,10 @@ fun jsExp mode skip outer = PConVar n => str (Int.toString n) | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"") - - fun isNullable (t, _) = case t of TOption _ => true + | TRecord [] => true | _ => false fun unsupported s = @@ -154,7 +154,7 @@ fun jsExp mode skip outer = | EPrim p => (str (Prim.toString p), st) | ERel n => if n < inner then - (str ("uwr" ^ var n), st) + (str ("_" ^ var n), st) else let val n = n - inner @@ -246,10 +246,10 @@ fun jsExp mode skip outer = let val locals = List.tabulate (varDepth e, - fn i => str ("var uwr" ^ Int.toString (len + inner + i) ^ ";")) + fn i => str ("var _" ^ Int.toString (len + inner + i) ^ ";")) val (e, st) = jsE (inner + 1) (e, st) in - (strcat (str ("function(uwr" + (strcat (str ("function(_" ^ Int.toString (len + inner) ^ "){") :: locals @@ -286,7 +286,7 @@ fun jsExp mode skip outer = let val (e, st) = jsE inner (e, st) in - (strcat [str "{uw_x:", e, str "}"], st) + (strcat [str "{_x:", e, str "}"], st) end | ERecord ((x, e, _) :: xes) => let @@ -297,14 +297,14 @@ fun jsExp mode skip outer = let val (e, st) = jsE inner (e, st) in - (str (",uw_" ^ x ^ ":") + (str (",_" ^ x ^ ":") :: e :: es, st) end) ([str "}"], st) xes in - (strcat (str ("{uw_" ^ x ^ ":") + (strcat (str ("{_" ^ x ^ ":") :: e :: es), st) @@ -314,7 +314,7 @@ fun jsExp mode skip outer = val (e, st) = jsE inner (e, st) in (strcat [e, - str ("." ^ x)], st) + str ("._" ^ x)], st) end | ECase _ => raise Fail "Jscomp: ECase" @@ -356,7 +356,7 @@ fun jsExp mode skip outer = val (e1, st) = jsE inner (e1, st) val (e2, st) = jsE (inner + 1) (e2, st) in - (strcat [str ("(uwr" ^ Int.toString (len + inner) ^ "="), + (strcat [str ("(_" ^ Int.toString (len + inner) ^ "="), e1, str ",", e2, @@ -415,7 +415,7 @@ val decl : state -> decl -> decl * state = val locals = List.tabulate (varDepth e, - fn i => str ("var uwr" ^ Int.toString (len + i) ^ ";")) + fn i => str ("var _" ^ Int.toString (len + i) ^ ";")) val (e, st) = jsExp m skip env 0 (e, st) in (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st) diff --git a/tests/stypes.ur b/tests/stypes.ur index 6368d5c9..4d918a91 100644 --- a/tests/stypes.ur +++ b/tests/stypes.ur @@ -1,5 +1,14 @@ fun main () : transaction page = sInt <- source 0; + sFloat <- source 1.23; + sBoth <- source (7, 42.1); + + sOpt <- source None; + return - {[n]}}/> Change
    + {[n + 3]}    }/> Change
    + + {[n + 1.0]}    }/> Change
    + + {[p.1]}, {[p.2]}    }/> Change
     -- cgit v1.2.3 From 914c437ab2251be982c4c19f659589360bf41a59 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 1 Jan 2009 10:49:42 -0500 Subject: Used an option as a source --- jslib/urweb.js | 1 + src/jscomp.sml | 104 ++++++++++++++++++++++++++++++++++++++++++++++---------- tests/stypes.ur | 5 +++ 3 files changed, 92 insertions(+), 18 deletions(-) diff --git a/jslib/urweb.js b/jslib/urweb.js index e661a739..fec37d1b 100644 --- a/jslib/urweb.js +++ b/jslib/urweb.js @@ -42,3 +42,4 @@ function dyn(s) { } function ts(x) { return x.toString() } +function pf() { alert("Pattern match failure") } diff --git a/src/jscomp.sml b/src/jscomp.sml index c6299f83..91ec56a7 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -133,25 +133,64 @@ fun jsExp mode skip outer = | _ => (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 => + str ("\"" + ^ String.translate (fn #"'" => + if mode = Attribute then + "\\047" + else + "'" + | #"\"" => "\\\"" + | #"<" => + if mode = Script then + "<" + else + "\\074" + | #"\\" => "\\\\" + | ch => String.str ch) s + ^ "\"") + | _ => str (Prim.toString p) + + fun jsPat inner (p, _) succ fail = + case p of + PWild => succ + | PVar _ => strcat [str ("(_" ^ Int.toString (len + inner) ^ "=d,"), + succ, + str ")"] + | PPrim p => strcat [str "(d==", + jsPrim p, + str "?", + succ, + str ":", + fail, + str ")"] + | PCon _ => raise Fail "jsPat: PCon" + | PRecord xps => + let + val (_, succ) = foldl + (fn ((x, p, _), (inner, succ)) => + (inner + E.patBindsN p, + jsPat inner p succ fail)) + (inner, succ) xps + in + succ + end + | PNone _ => strcat [str "(d?", + fail, + str ":", + succ, + str ")"] + | PSome (_, p) => strcat [str "(d?", + jsPat inner p succ fail, + str ":", + fail, + str ")"] in case #1 e of - EPrim (Prim.String s) => - (str ("\"" - ^ String.translate (fn #"'" => - if mode = Attribute then - "\\047" - else - "'" - | #"\"" => "\\\"" - | #"<" => - if mode = Script then - "<" - else - "\\074" - | #"\\" => "\\\\" - | ch => String.str ch) s - ^ "\""), st) - | EPrim p => (str (Prim.toString p), st) + EPrim p => (jsPrim p, st) | ERel n => if n < inner then (str ("_" ^ var n), st) @@ -317,7 +356,36 @@ fun jsExp mode skip outer = str ("._" ^ x)], st) end - | ECase _ => raise Fail "Jscomp: ECase" + | ECase (e, pes, _) => + let + val plen = length pes + + val (cases, st) = ListUtil.foldliMap + (fn (i, (p, e), st) => + let + val (e, st) = jsE (inner + E.patBindsN p) (e, st) + val fail = + if i = plen - 1 then + str "pf()" + else + str ("c" ^ Int.toString (i+1) ^ "()") + val c = jsPat inner p e fail + in + (strcat [str ("c" ^ Int.toString i ^ "=function(){return "), + c, + str "},"], + st) + end) + st pes + + val (e, st) = jsE inner (e, st) + in + (strcat (str "(" + :: List.revAppend (cases, + [str "d=", + e, + str ",c0())"])), st) + end | EStrcat (e1, e2) => let diff --git a/tests/stypes.ur b/tests/stypes.ur index 4d918a91..1ac70834 100644 --- a/tests/stypes.ur +++ b/tests/stypes.ur @@ -11,4 +11,9 @@ fun main () : transaction page = {[n + 1.0]}    }/> Change
    {[p.1]}, {[p.2]}    }/> Change
    + + return None + | Some n => return {[n]}}/> + Change
     -- cgit v1.2.3 From 6c16d6f8418dbf32b4c17067d7f9617bbdc2ad8f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 1 Jan 2009 11:04:09 -0500 Subject: Reactive record pattern --- jslib/urweb.js | 2 +- src/jscomp.sml | 23 +++++++++++++---------- tests/stypes.ur | 6 +++++- 3 files changed, 19 insertions(+), 12 deletions(-) diff --git a/jslib/urweb.js b/jslib/urweb.js index fec37d1b..904e27e8 100644 --- a/jslib/urweb.js +++ b/jslib/urweb.js @@ -2,7 +2,7 @@ function cons(v, ls) { return { n : ls, v : v }; } function callAll(ls) { - for (; ls; ls = ls.next) + for (; ls; ls = ls.n) ls.v(); } diff --git a/src/jscomp.sml b/src/jscomp.sml index 91ec56a7..ef27dba9 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -154,13 +154,13 @@ fun jsExp mode skip outer = ^ "\"") | _ => str (Prim.toString p) - fun jsPat inner (p, _) succ fail = + fun jsPat depth inner (p, _) succ fail = case p of PWild => succ - | PVar _ => strcat [str ("(_" ^ Int.toString (len + inner) ^ "=d,"), + | PVar _ => strcat [str ("(_" ^ Int.toString (len + inner) ^ "=d" ^ Int.toString depth ^ ","), succ, str ")"] - | PPrim p => strcat [str "(d==", + | PPrim p => strcat [str ("(d" ^ Int.toString depth ^ "=="), jsPrim p, str "?", succ, @@ -173,18 +173,21 @@ fun jsExp mode skip outer = val (_, succ) = foldl (fn ((x, p, _), (inner, succ)) => (inner + E.patBindsN p, - jsPat inner p succ fail)) + strcat [str ("(d" ^ Int.toString (depth+1) ^ "=d" + ^ Int.toString depth ^ "._" ^ x ^ ","), + jsPat (depth+1) inner p succ fail, + str ")"])) (inner, succ) xps in succ end - | PNone _ => strcat [str "(d?", + | PNone _ => strcat [str ("(d" ^ Int.toString depth ^ "?"), fail, str ":", succ, str ")"] - | PSome (_, p) => strcat [str "(d?", - jsPat inner p succ fail, + | PSome (_, p) => strcat [str ("(d" ^ Int.toString depth ^ "?"), + jsPat depth inner p succ fail, str ":", fail, str ")"] @@ -285,7 +288,7 @@ fun jsExp mode skip outer = let val locals = List.tabulate (varDepth e, - fn i => str ("var _" ^ Int.toString (len + inner + i) ^ ";")) + fn i => str ("var _" ^ Int.toString (len + inner + i + 1) ^ ";")) val (e, st) = jsE (inner + 1) (e, st) in (strcat (str ("function(_" @@ -369,7 +372,7 @@ fun jsExp mode skip outer = str "pf()" else str ("c" ^ Int.toString (i+1) ^ "()") - val c = jsPat inner p e fail + val c = jsPat 0 inner p e fail in (strcat [str ("c" ^ Int.toString i ^ "=function(){return "), c, @@ -382,7 +385,7 @@ fun jsExp mode skip outer = in (strcat (str "(" :: List.revAppend (cases, - [str "d=", + [str "d0=", e, str ",c0())"])), st) end diff --git a/tests/stypes.ur b/tests/stypes.ur index 1ac70834..08de343f 100644 --- a/tests/stypes.ur +++ b/tests/stypes.ur @@ -10,7 +10,11 @@ fun main () : transaction page = {[n + 1.0]}    }/> Change
    - {[p.1]}, {[p.2]}    }/> Change
    + {[p.1]}, {[p.2]}    }/>; + return Initial + | (fst, snd) => return {[fst]}, {[snd]}}/> + Change
    return None -- cgit v1.2.3 From e0d59f2e5dc62dbc99a7f85197b4b3c63fcaf101 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 1 Jan 2009 11:13:08 -0500 Subject: Reactive bool --- jslib/urweb.js | 2 ++ src/jscomp.sml | 3 +++ tests/stypes.ur | 3 +++ 3 files changed, 8 insertions(+) diff --git a/jslib/urweb.js b/jslib/urweb.js index 904e27e8..46c24bff 100644 --- a/jslib/urweb.js +++ b/jslib/urweb.js @@ -42,4 +42,6 @@ function dyn(s) { } function ts(x) { return x.toString() } +function bs(b) { return (b ? "True" : "False") } + function pf() { alert("Pattern match failure") } diff --git a/src/jscomp.sml b/src/jscomp.sml index ef27dba9..ac3c9792 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -34,6 +34,7 @@ structure E = MonoEnv structure U = MonoUtil val funcs = [(("Basis", "alert"), "alert"), + (("Basis", "htmlifyBool"), "bs"), (("Basis", "htmlifyFloat"), "ts"), (("Basis", "htmlifyInt"), "ts"), (("Basis", "htmlifyString"), "escape"), @@ -110,6 +111,8 @@ fun jsExp mode skip outer = fun patCon pc = case pc of PConVar n => str (Int.toString n) + | PConFfi {mod = "Basis", con = "True", ...} => str "true" + | PConFfi {mod = "Basis", con = "False", ...} => str "false" | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"") fun isNullable (t, _) = diff --git a/tests/stypes.ur b/tests/stypes.ur index 08de343f..e5006465 100644 --- a/tests/stypes.ur +++ b/tests/stypes.ur @@ -4,6 +4,7 @@ fun main () : transaction page = sBoth <- source (7, 42.1); sOpt <- source None; + sBool <- source True; return {[n + 3]}}/> Change
    @@ -20,4 +21,6 @@ fun main () : transaction page = None => return None | Some n => return {[n]}}/> Change
    + + {[b]}    }/> Change
     -- cgit v1.2.3 From 783f041bd07a2a7fb308c1c7d474d8997ff5ab12 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 1 Jan 2009 11:16:57 -0500 Subject: Reactive if --- src/jscomp.sml | 14 +++++++++++++- tests/stypes.ur | 4 +++- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/src/jscomp.sml b/src/jscomp.sml index ac3c9792..5e7a2673 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -170,7 +170,19 @@ fun jsExp mode skip outer = str ":", fail, str ")"] - | PCon _ => raise Fail "jsPat: PCon" + | PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE) => + strcat [str ("(d" ^ Int.toString depth ^ "?"), + succ, + str ":", + fail, + str ")"] + | PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE) => + strcat [str ("(d" ^ Int.toString depth ^ "?"), + fail, + str ":", + succ, + str ")"] + | PCon _ => raise Fail "PCon" | PRecord xps => let val (_, succ) = foldl diff --git a/tests/stypes.ur b/tests/stypes.ur index e5006465..c752234c 100644 --- a/tests/stypes.ur +++ b/tests/stypes.ur @@ -22,5 +22,7 @@ fun main () : transaction page = | Some n => return {[n]}}/> Change
    - {[b]}    }/> Change
    + {[b]}    }/> + Yes     else return No}/> + Change
     -- cgit v1.2.3 From 1b475375ced4a2482cc90262e32ed42397025cc6 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 1 Jan 2009 11:26:34 -0500 Subject: Basic datatype reactives --- src/jscomp.sml | 17 ++++++++++++++++- tests/stypes.ur | 33 +++++++++++++++++++++++++++++++++ 2 files changed, 49 insertions(+), 1 deletion(-) diff --git a/src/jscomp.sml b/src/jscomp.sml index 5e7a2673..72d5cde5 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -182,7 +182,22 @@ fun jsExp mode skip outer = str ":", succ, str ")"] - | PCon _ => raise Fail "PCon" + | PCon (_, pc, NONE) => + strcat [str ("(d" ^ Int.toString depth ^ "=="), + patCon pc, + str "?", + succ, + str ":", + fail, + str ")"] + | PCon (_, pc, SOME p) => + strcat [str ("(d" ^ Int.toString depth ^ ".n=="), + patCon pc, + str ("?(d" ^ Int.toString depth ^ "=d" ^ Int.toString depth ^ ".v,"), + succ, + str "):", + fail, + str ")"] | PRecord xps => let val (_, succ) = foldl diff --git a/tests/stypes.ur b/tests/stypes.ur index c752234c..6c590843 100644 --- a/tests/stypes.ur +++ b/tests/stypes.ur @@ -1,3 +1,25 @@ +datatype color = Red | White | Blue + +fun c2s c = + case c of + Red => "Red" + | White => "White" + | Blue => "Blue" + +val show_color = mkShow c2s + +datatype list a = Nil | Cons of a * list a + +fun isNil (t ::: Type) (ls : list t) = + case ls of + Nil => True + | _ => False + +fun delist (ls : list string) : xml body [] [] = + case ls of + Nil => Nil + | Cons (h, t) => {[h]} :: {delist t} + fun main () : transaction page = sInt <- source 0; sFloat <- source 1.23; @@ -6,6 +28,9 @@ fun main () : transaction page = sOpt <- source None; sBool <- source True; + sColor <- source White; + sList <- source Nil; + return {[n + 3]}}/> Change
    @@ -25,4 +50,12 @@ fun main () : transaction page = {[b]}}/> Yes else return No}/> Change
    + + {[c]}}/> + Red + White + Blue
    + + {[isNil ls]}}/> + Change
    -- cgit v1.2.3 From ef3b3f91435a9a924771c373dc53547e2ebd4503 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 1 Jan 2009 11:58:00 -0500 Subject: Included a recursive function in JavaScript --- jslib/urweb.js | 1 + src/jscomp.sml | 874 ++++++++++++++++++++++++++++++-------------------------- tests/stypes.ur | 3 +- 3 files changed, 465 insertions(+), 413 deletions(-) diff --git a/jslib/urweb.js b/jslib/urweb.js index 46c24bff..16424eb3 100644 --- a/jslib/urweb.js +++ b/jslib/urweb.js @@ -45,3 +45,4 @@ function ts(x) { return x.toString() } function bs(b) { return (b ? "True" : "False") } function pf() { alert("Pattern match failure") } + diff --git a/src/jscomp.sml b/src/jscomp.sml index 72d5cde5..67d8d9c1 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -33,6 +33,9 @@ structure EM = ErrorMsg structure E = MonoEnv structure U = MonoUtil +structure IS = IntBinarySet +structure IM = IntBinaryMap + val funcs = [(("Basis", "alert"), "alert"), (("Basis", "htmlifyBool"), "bs"), (("Basis", "htmlifyFloat"), "ts"), @@ -54,7 +57,8 @@ fun ffi k = FM.find (funcs, k) type state = { decls : decl list, - script : string + script : string list, + included : IS.set } fun varDepth (e, _) = @@ -98,454 +102,500 @@ fun strcat loc es = | [x] => x | x :: es' => (EStrcat (x, strcat loc es'), loc) -fun jsExp mode skip outer = +fun process file = let - val len = length outer - - fun jsE inner (e as (_, loc), st) = + val nameds = foldl (fn ((DVal (_, n, t, e, _), _), nameds) => IM.insert (nameds, n, e) + | ((DValRec vis, _), nameds) => + foldl (fn ((_, n, _, e, _), nameds) => IM.insert (nameds, n, e)) + nameds vis + | (_, nameds) => nameds) + IM.empty file + + fun jsExp mode skip outer = let - fun str s = (EPrim (Prim.String s), loc) - - fun var n = Int.toString (len + inner - n - 1) - - fun patCon pc = - case pc of - PConVar n => str (Int.toString n) - | PConFfi {mod = "Basis", con = "True", ...} => str "true" - | PConFfi {mod = "Basis", con = "False", ...} => str "false" - | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"") - - fun isNullable (t, _) = - case t of - TOption _ => true - | TRecord [] => true - | _ => false - - fun unsupported s = - (EM.errorAt loc (s ^ " in code to be compiled to JavaScript"); - (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)] - | 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 => - str ("\"" - ^ String.translate (fn #"'" => - if mode = Attribute then - "\\047" - else - "'" - | #"\"" => "\\\"" - | #"<" => - if mode = Script then - "<" - else - "\\074" - | #"\\" => "\\\\" - | ch => String.str ch) s - ^ "\"") - | _ => str (Prim.toString p) - - fun jsPat depth inner (p, _) succ fail = - case p of - PWild => succ - | PVar _ => strcat [str ("(_" ^ Int.toString (len + inner) ^ "=d" ^ Int.toString depth ^ ","), - succ, - str ")"] - | PPrim p => strcat [str ("(d" ^ Int.toString depth ^ "=="), - jsPrim p, - str "?", - succ, - str ":", - fail, - str ")"] - | PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE) => - strcat [str ("(d" ^ Int.toString depth ^ "?"), - succ, - str ":", - fail, - str ")"] - | PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE) => - strcat [str ("(d" ^ Int.toString depth ^ "?"), - fail, - str ":", - succ, - str ")"] - | PCon (_, pc, NONE) => - strcat [str ("(d" ^ Int.toString depth ^ "=="), - patCon pc, - str "?", - succ, - str ":", - fail, - str ")"] - | PCon (_, pc, SOME p) => - strcat [str ("(d" ^ Int.toString depth ^ ".n=="), - patCon pc, - str ("?(d" ^ Int.toString depth ^ "=d" ^ Int.toString depth ^ ".v,"), - succ, - str "):", - fail, - str ")"] - | PRecord xps => - let - val (_, succ) = foldl - (fn ((x, p, _), (inner, succ)) => - (inner + E.patBindsN p, - strcat [str ("(d" ^ Int.toString (depth+1) ^ "=d" - ^ Int.toString depth ^ "._" ^ x ^ ","), - jsPat (depth+1) inner p succ fail, - str ")"])) - (inner, succ) xps - in - succ - end - | PNone _ => strcat [str ("(d" ^ Int.toString depth ^ "?"), - fail, - str ":", - succ, - str ")"] - | PSome (_, p) => strcat [str ("(d" ^ Int.toString depth ^ "?"), - jsPat depth inner p succ fail, - str ":", - fail, - str ")"] - in - case #1 e of - EPrim p => (jsPrim p, st) - | ERel n => - if n < inner then - (str ("_" ^ var n), st) - else - let - val n = n - inner - in - (quoteExp (List.nth (outer, n)) (ERel (n - skip), loc), st) - end - | ENamed _ => raise Fail "Named" - | ECon (_, pc, NONE) => (patCon pc, st) - | ECon (_, pc, SOME e) => - let - val (s, st) = jsE inner (e, st) - in - (strcat [str "{n:", - patCon pc, - str ",v:", - s, - str "}"], st) - end - | ENone _ => (str "null", st) - | ESome (t, e) => - let - val (e, st) = jsE inner (e, st) - in - (if isNullable t then - strcat [str "{v:", e, str "}"] - else - e, st) - end + val len = length outer - | EFfi k => + fun jsE inner (e as (_, loc), st) = let - val name = case ffi k of - NONE => (EM.errorAt loc ("Unsupported FFI identifier " ^ #2 k ^ " in JavaScript"); - "ERROR") - | SOME s => s + fun str s = (EPrim (Prim.String s), loc) + + fun var n = Int.toString (len + inner - n - 1) + + fun patCon pc = + case pc of + PConVar n => str (Int.toString n) + | PConFfi {mod = "Basis", con = "True", ...} => str "true" + | PConFfi {mod = "Basis", con = "False", ...} => str "false" + | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"") + + fun isNullable (t, _) = + case t of + TOption _ => true + | TRecord [] => true + | _ => false + + fun unsupported s = + (EM.errorAt loc (s ^ " in code to be compiled to JavaScript"); + (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)] + | 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 => + str ("\"" + ^ String.translate (fn #"'" => + if mode = Attribute then + "\\047" + else + "'" + | #"\"" => "\\\"" + | #"<" => + if mode = Script then + "<" + else + "\\074" + | #"\\" => "\\\\" + | ch => String.str ch) s + ^ "\"") + | _ => str (Prim.toString p) + + fun jsPat depth inner (p, _) succ fail = + case p of + PWild => succ + | PVar _ => strcat [str ("(_" ^ Int.toString (len + inner) ^ "=d" + ^ Int.toString depth ^ ","), + succ, + str ")"] + | PPrim p => strcat [str ("(d" ^ Int.toString depth ^ "=="), + jsPrim p, + str "?", + succ, + str ":", + fail, + str ")"] + | PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE) => + strcat [str ("(d" ^ Int.toString depth ^ "?"), + succ, + str ":", + fail, + str ")"] + | PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE) => + strcat [str ("(d" ^ Int.toString depth ^ "?"), + fail, + str ":", + succ, + str ")"] + | PCon (_, pc, NONE) => + strcat [str ("(d" ^ Int.toString depth ^ "=="), + patCon pc, + str "?", + succ, + str ":", + fail, + str ")"] + | PCon (_, pc, SOME p) => + strcat [str ("(d" ^ Int.toString depth ^ ".n=="), + patCon pc, + str ("?(d" ^ Int.toString depth ^ "=d" ^ Int.toString depth ^ ".v,"), + jsPat depth inner p succ fail, + str "):", + fail, + str ")"] + | PRecord xps => + let + val (_, succ) = foldl + (fn ((x, p, _), (inner, succ)) => + (inner + E.patBindsN p, + strcat [str ("(d" ^ Int.toString (depth+1) ^ "=d" + ^ Int.toString depth ^ "._" ^ x ^ ","), + jsPat (depth+1) inner p succ fail, + str ")"])) + (inner, succ) xps + in + succ + end + | PNone _ => strcat [str ("(d" ^ Int.toString depth ^ "?"), + fail, + str ":", + succ, + str ")"] + | PSome (_, p) => strcat [str ("(d" ^ Int.toString depth ^ "?"), + jsPat depth inner p succ fail, + str ":", + fail, + str ")"] + + fun deStrcat (e, _) = + case e of + EPrim (Prim.String s) => s + | EStrcat (e1, e2) => deStrcat e1 ^ deStrcat e2 + | _ => raise Fail "Jscomp: deStrcat" in - (str name, st) - 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") - | SOME s => s - in - case args of - [] => (str (name ^ "()"), st) - | [e] => + case #1 e of + EPrim p => (jsPrim p, st) + | ERel n => + if n < inner then + (str ("_" ^ var n), st) + else + let + val n = n - inner + in + (quoteExp (List.nth (outer, n)) (ERel (n - skip), loc), st) + end + + | ENamed n => let - val (e, st) = jsE inner (e, st) + val st = + if IS.member (#included st, n) then + st + else + case IM.find (nameds, n) of + NONE => raise Fail "Jscomp: Unbound ENamed" + | SOME e => + let + val st = {decls = #decls st, + script = #script st, + included = IS.add (#included st, n)} + + val (e, st) = jsExp mode skip [] 0 (e, st) + val e = deStrcat e + + val sc = "_n" ^ Int.toString n ^ "=" ^ e ^ ";\n" + in + {decls = #decls st, + script = sc :: #script st, + included = #included st} + end in - (strcat [str (name ^ "("), - e, - str ")"], st) + (str ("_n" ^ Int.toString n), st) end - | e :: es => + + | ECon (_, pc, NONE) => (patCon pc, st) + | ECon (_, pc, SOME e) => + let + val (s, st) = jsE inner (e, st) + in + (strcat [str "{n:", + patCon pc, + str ",v:", + s, + str "}"], st) + end + | ENone _ => (str "null", st) + | ESome (t, e) => 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) + (if isNullable t then + strcat [str "{v:", e, str "}"] + else + e, st) end - end - | EApp (e1, e2) => - let - val (e1, st) = jsE inner (e1, st) - val (e2, st) = jsE inner (e2, st) - in - (strcat [e1, str "(", e2, str ")"], st) - end - | EAbs (_, _, _, e) => - let - val locals = List.tabulate - (varDepth e, - fn i => str ("var _" ^ Int.toString (len + inner + i + 1) ^ ";")) - val (e, st) = jsE (inner + 1) (e, st) - in - (strcat (str ("function(_" - ^ Int.toString (len + inner) - ^ "){") - :: locals - @ [str "return ", - e, - str "}"]), - st) - end + | EFfi k => + let + val name = case ffi k of + NONE => (EM.errorAt loc ("Unsupported FFI identifier " ^ #2 k + ^ " in JavaScript"); + "ERROR") + | SOME s => s + in + (str name, st) + 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") + | SOME s => s + in + 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 - | EUnop (s, e) => - let - val (e, st) = jsE inner (e, st) - in - (strcat [str ("(" ^ s), - e, - str ")"], - st) - end - | EBinop (s, e1, e2) => - let - val (e1, st) = jsE inner (e1, st) - val (e2, st) = jsE inner (e2, st) - in - (strcat [str "(", - e1, - str s, - e2, - str ")"], - st) - end + | EApp (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [e1, str "(", e2, str ")"], st) + end + | EAbs (_, _, _, e) => + let + val locals = List.tabulate + (varDepth e, + fn i => str ("var _" ^ Int.toString (len + inner + i + 1) ^ ";")) + val (e, st) = jsE (inner + 1) (e, st) + in + (strcat (str ("function(_" + ^ Int.toString (len + inner) + ^ "){") + :: locals + @ [str "return ", + e, + str "}"]), + st) + end - | ERecord [] => (str "null", st) - | ERecord [(x, e, _)] => - let - val (e, st) = jsE inner (e, st) - in - (strcat [str "{_x:", e, str "}"], st) - end - | ERecord ((x, e, _) :: xes) => - let - val (e, st) = jsE inner (e, st) + | EUnop (s, e) => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str ("(" ^ s), + e, + str ")"], + st) + end + | EBinop (s, e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "(", + e1, + str s, + e2, + str ")"], + st) + end - val (es, st) = - foldr (fn ((x, e, _), (es, st)) => - let - val (e, st) = jsE inner (e, st) - in - (str (",_" ^ x ^ ":") - :: e - :: es, - st) - end) - ([str "}"], st) xes - in - (strcat (str ("{_" ^ x ^ ":") - :: e - :: es), - st) - end - | EField (e, x) => - let - val (e, st) = jsE inner (e, st) - in - (strcat [e, - str ("._" ^ x)], st) - end + | ERecord [] => (str "null", st) + | ERecord [(x, e, _)] => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "{_x:", e, str "}"], st) + end + | ERecord ((x, e, _) :: xes) => + let + val (e, st) = jsE inner (e, st) - | ECase (e, pes, _) => - let - val plen = length pes - - val (cases, st) = ListUtil.foldliMap - (fn (i, (p, e), st) => - let - val (e, st) = jsE (inner + E.patBindsN p) (e, st) - val fail = - if i = plen - 1 then - str "pf()" - else - str ("c" ^ Int.toString (i+1) ^ "()") - val c = jsPat 0 inner p e fail - in - (strcat [str ("c" ^ Int.toString i ^ "=function(){return "), - c, - str "},"], - st) - end) - st pes - - val (e, st) = jsE inner (e, st) - in - (strcat (str "(" - :: List.revAppend (cases, - [str "d0=", - e, - str ",c0())"])), st) - end + val (es, st) = + foldr (fn ((x, e, _), (es, st)) => + let + val (e, st) = jsE inner (e, st) + in + (str (",_" ^ x ^ ":") + :: e + :: es, + st) + end) + ([str "}"], st) xes + in + (strcat (str ("{_" ^ x ^ ":") + :: e + :: es), + st) + end + | EField (e, x) => + let + val (e, st) = jsE inner (e, st) + in + (strcat [e, + str ("._" ^ x)], st) + end - | EStrcat (e1, e2) => - let - val (e1, st) = jsE inner (e1, st) - val (e2, st) = jsE inner (e2, st) - in - (strcat [str "(", e1, str "+", e2, str ")"], st) - end + | ECase (e, pes, _) => + let + val plen = length pes + + val (cases, st) = ListUtil.foldliMap + (fn (i, (p, e), st) => + let + val (e, st) = jsE (inner + E.patBindsN p) (e, st) + val fail = + if i = plen - 1 then + str "pf()" + else + str ("c" ^ Int.toString (i+1) ^ "()") + val c = jsPat 0 inner p e fail + in + (strcat [str ("c" ^ Int.toString i ^ "=function(){return "), + c, + str "},"], + st) + end) + st pes - | EError (e, _) => - let - val (e, st) = jsE inner (e, st) - in - (strcat [str "alert(\"ERROR: \"+", e, str ")"], - st) - end + val (e, st) = jsE inner (e, st) + in + (strcat (str "(" + :: List.revAppend (cases, + [str "d0=", + e, + str ",c0())"])), st) + end - | EWrite e => - let - val (e, st) = jsE inner (e, st) - in - (strcat [str "document.write(", - e, - str ".v)"], st) - end + | EStrcat (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "(", e1, str "+", e2, str ")"], st) + end - | ESeq (e1, e2) => - let - val (e1, st) = jsE inner (e1, st) - val (e2, st) = jsE inner (e2, st) - in - (strcat [str "(", e1, str ",", e2, str ")"], st) - end - | ELet (_, _, e1, e2) => - let - val (e1, st) = jsE inner (e1, st) - val (e2, st) = jsE (inner + 1) (e2, st) - in - (strcat [str ("(_" ^ Int.toString (len + inner) ^ "="), - e1, - str ",", - e2, - str ")"], st) - end + | EError (e, _) => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "alert(\"ERROR: \"+", e, str ")"], + st) + end - | EClosure _ => unsupported "EClosure" - | EQuery _ => unsupported "Query" - | EDml _ => unsupported "DML" - | ENextval _ => unsupported "Nextval" - | EUnurlify _ => unsupported "EUnurlify" - | EJavaScript _ => unsupported "Nested JavaScript" - | ESignalReturn e => - let - val (e, st) = jsE inner (e, st) - in - (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 - | ESignalSource e => - let - val (e, st) = jsE inner (e, st) - in - (strcat [str "ss(", - e, - str ")"], - st) + | EWrite e => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "document.write(", + e, + str ".v)"], st) + end + + | ESeq (e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE inner (e2, st) + in + (strcat [str "(", e1, str ",", e2, str ")"], st) + end + | ELet (_, _, e1, e2) => + let + val (e1, st) = jsE inner (e1, st) + val (e2, st) = jsE (inner + 1) (e2, st) + in + (strcat [str ("(_" ^ Int.toString (len + inner) ^ "="), + e1, + str ",", + e2, + str ")"], st) + end + + | EClosure _ => unsupported "EClosure" + | EQuery _ => unsupported "Query" + | EDml _ => unsupported "DML" + | ENextval _ => unsupported "Nextval" + | EUnurlify _ => unsupported "EUnurlify" + | EJavaScript _ => unsupported "Nested JavaScript" + | ESignalReturn e => + let + val (e, st) = jsE inner (e, st) + in + (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 + | ESignalSource e => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "ss(", + e, + str ")"], + st) + end end + in + jsE end - in - jsE - end -val decl : state -> decl -> decl * state = - U.Decl.foldMapB {typ = fn x => x, - exp = fn (env, e, st) => - let - fun doCode m skip env orig e = + val decl : state -> decl -> decl * state = + U.Decl.foldMapB {typ = fn x => x, + exp = fn (env, e, st) => let - val len = length env - fun str s = (EPrim (Prim.String s), #2 e) - - val locals = List.tabulate - (varDepth e, - fn i => str ("var _" ^ Int.toString (len + i) ^ ";")) - val (e, st) = jsExp m skip env 0 (e, st) + fun doCode m skip env orig 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 _" ^ Int.toString (len + i) ^ ";")) + val (e, st) = jsExp m skip env 0 (e, st) + in + (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st) + end in - (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st) - 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 - | _ => (e, st) - end, - decl = fn (_, e, st) => (e, st), - bind = fn (env, U.Decl.RelE (_, t)) => t :: env - | (env, _) => env} - [] + 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 + | _ => (e, st) + end, + decl = fn (_, e, st) => (e, st), + bind = fn (env, U.Decl.RelE (_, t)) => t :: env + | (env, _) => env} + [] -fun process file = - let fun doDecl (d, st) = let val (d, st) = decl st d in (List.revAppend (#decls st, [d]), {decls = [], - script = #script st}) + script = #script st, + included = #included st}) end val (ds, st) = ListUtil.foldlMapConcat doDecl {decls = [], - script = ""} + script = [], + included = IS.empty} file val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.libJs, file = "urweb.js"}) @@ -556,7 +606,7 @@ fun process file = val lines = lines [] in TextIO.closeIn inf; - (DJavaScript lines, ErrorMsg.dummySpan) :: ds + (DJavaScript (lines ^ String.concat (rev (#script st))), ErrorMsg.dummySpan) :: ds end end diff --git a/tests/stypes.ur b/tests/stypes.ur index 6c590843..142925e5 100644 --- a/tests/stypes.ur +++ b/tests/stypes.ur @@ -56,6 +56,7 @@ fun main () : transaction page = White Blue
    - {[isNil ls]}}/> + {[isNil ls]}}/>; + {delist ls}}/> Change
    -- 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 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 17ffca0b16e45aa093a9c1d55b0e629a4cf26798 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 1 Jan 2009 15:59:02 -0500 Subject: Injecting a float --- src/c/urweb.c | 1 - src/errormsg.sml | 2 +- src/jscomp.sml | 142 ++++++++++++++++++++++++++++++++--------------------- src/mono_print.sml | 11 ++++- tests/jsinj.ur | 18 +++++-- 5 files changed, 111 insertions(+), 63 deletions(-) diff --git a/src/c/urweb.c b/src/c/urweb.c index 2c6d493a..54646fd8 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -363,7 +363,6 @@ 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); } } diff --git a/src/errormsg.sml b/src/errormsg.sml index e816b9a2..f402c5aa 100644 --- a/src/errormsg.sml +++ b/src/errormsg.sml @@ -95,7 +95,7 @@ fun error s = (TextIO.output (TextIO.stdErr, s); TextIO.output1 (TextIO.stdErr, #"\n"); errors := true) fun errorAt span s = (TextIO.output (TextIO.stdErr, spanToString span); - TextIO.output1 (TextIO.stdErr, #" "); + TextIO.output (TextIO.stdErr, ": "); error s) fun errorAt' span s = errorAt (spanOf span) s diff --git a/src/jscomp.sml b/src/jscomp.sml index b27a860b..ca6508a9 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -96,14 +96,55 @@ fun varDepth (e, _) = | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2) | ESignalSource e => varDepth e +fun closedUpto d = + let + fun cu inner (e, _) = + case e of + EPrim _ => true + | ERel n => n < inner orelse n - inner >= d + | ENamed _ => true + | ECon (_, _, NONE) => true + | ECon (_, _, SOME e) => cu inner e + | ENone _ => true + | ESome (_, e) => cu inner e + | EFfi _ => true + | EFfiApp (_, _, es) => List.all (cu inner) es + | EApp (e1, e2) => cu inner e1 andalso cu inner e2 + | EAbs (_, _, _, e) => cu (inner + 1) e + | EUnop (_, e) => cu inner e + | EBinop (_, e1, e2) => cu inner e1 andalso cu inner e2 + | ERecord xes => List.all (fn (_, e, _) => cu inner e) xes + | EField (e, _) => cu inner e + | ECase (e, pes, _) => + cu inner e + andalso List.all (fn (p, e) => cu (inner + E.patBindsN p) e) pes + | EStrcat (e1, e2) => cu inner e1 andalso cu inner e2 + | EError (e, _) => cu inner e + | EWrite e => cu inner e + | ESeq (e1, e2) => cu inner e1 andalso cu inner e2 + | ELet (_, _, e1, e2) => cu inner e1 andalso cu (inner + 1) e2 + | EClosure (_, es) => List.all (cu inner) es + | EQuery {query, body, initial, ...} => + cu inner query + andalso cu (inner + 2) body + andalso cu inner initial + | EDml e => cu inner e + | ENextval e => cu inner e + | EUnurlify (e, _) => cu inner e + | EJavaScript (_, e, _) => cu inner e + | ESignalReturn e => cu inner e + | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2 + | ESignalSource e => cu inner e + in + cu 0 + end + fun strcat loc es = case es of [] => (EPrim (Prim.String ""), loc) | [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) @@ -123,6 +164,7 @@ fun process file = | TFfi ("Basis", "string") => e | TFfi ("Basis", "int") => (EFfiApp ("Basis", "htmlifyInt", [e]), loc) + | TFfi ("Basis", "float") => (EFfiApp ("Basis", "htmlifyFloat", [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)]; @@ -151,7 +193,9 @@ fun process file = | TRecord [] => true | _ => false - fun unsupported s = raise Unsupported (s, loc) + fun unsupported s = + (EM.errorAt loc (s ^ " in code to be compiled to JavaScript[2]"); + (str "ERROR", st)) val strcat = strcat loc @@ -447,36 +491,40 @@ fun process file = str ("._" ^ x)], st) end - | ECase (e, pes, _) => - let - val plen = length pes - - val (cases, st) = ListUtil.foldliMap - (fn (i, (p, e), st) => - let - val (e, st) = jsE (inner + E.patBindsN p) (e, st) - val fail = - if i = plen - 1 then - str "pf()" - else - str ("c" ^ Int.toString (i+1) ^ "()") - val c = jsPat 0 inner p e fail - in - (strcat [str ("c" ^ Int.toString i ^ "=function(){return "), - c, - str "},"], - st) - end) - st pes - - val (e, st) = jsE inner (e, st) - in - (strcat (str "(" - :: List.revAppend (cases, - [str "d0=", - e, - str ",c0())"])), st) - end + | ECase (e', pes, {result, ...}) => + if closedUpto inner e andalso List.all (fn (_, e) => closedUpto inner e) pes then + ((ELet ("js", result, e, quoteExp result (ERel 0, loc)), loc), + st) + else + let + val plen = length pes + + val (cases, st) = ListUtil.foldliMap + (fn (i, (p, e), st) => + let + val (e, st) = jsE (inner + E.patBindsN p) (e, st) + val fail = + if i = plen - 1 then + str "pf()" + else + str ("c" ^ Int.toString (i+1) ^ "()") + val c = jsPat 0 inner p e fail + in + (strcat [str ("c" ^ Int.toString i ^ "=function(){return "), + c, + str "},"], + st) + end) + st pes + + val (e, st) = jsE inner (e', st) + in + (strcat (str "(" + :: List.revAppend (cases, + [str "d0=", + e, + str ",c0())"])), st) + end | EStrcat (e1, e2) => let @@ -522,7 +570,7 @@ fun process file = str ")"], st) end - | EJavaScript (_, _, SOME e) => (e, st) + | EJavaScript (_, _, SOME _) => (e, st) | EClosure _ => unsupported "EClosure" | EQuery _ => unsupported "Query" @@ -584,28 +632,10 @@ fun process file = end in case e of - 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))) - + EJavaScript (m, orig as (EAbs (_, t, _, e), _), NONE) => + doCode m 1 (t :: env) orig e + | EJavaScript (m, orig, NONE) => + doCode m 0 env orig orig | _ => (e, st) end, decl = fn (_, e, st) => (e, st), diff --git a/src/mono_print.sml b/src/mono_print.sml index f8a23d1d..1e9de3d8 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -120,6 +120,12 @@ fun p_pat' par env (p, _) = and p_pat x = p_pat' false x +fun p_mode env m = + case m of + Attribute => string "Attribute" + | Script => string "Script" + | Source t => box [string "Source", space, p_typ env t] + fun p_exp' par env (e, _) = case e of EPrim p => Prim.p_t p @@ -281,7 +287,10 @@ fun p_exp' par env (e, _) = | EUnurlify (e, _) => box [string "unurlify(", p_exp env e, string ")"] - | EJavaScript (_, e, NONE) => box [string "JavaScript(", + | EJavaScript (m, e, NONE) => box [string "JavaScript(", + p_mode env m, + string ",", + space, p_exp env e, string ")"] | EJavaScript (_, _, SOME e) => p_exp env e diff --git a/tests/jsinj.ur b/tests/jsinj.ur index 194d26be..d5bd7dbb 100644 --- a/tests/jsinj.ur +++ b/tests/jsinj.ur @@ -1,14 +1,24 @@ -cookie int : int - fun getOpt (t ::: Type) (o : option t) (v : t) : t = case o of None => v | Some x => x +cookie int : int +cookie float : float + fun main () : transaction page = n <- getCookie int; - sn <- source (getOpt n 7); + n <- return (getOpt n 7); + sn <- source 6; + + f <- getCookie float; + f <- return (getOpt f 1.23); + sf <- source 4.56; + return {[n]}}/> - CHANGE + CHANGE
    + + {[f]}}/> + CHANGE
    -- cgit v1.2.3 From 36e59f6512af87c02ba856372d71a6a47e9045fd Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 1 Jan 2009 16:11:42 -0500 Subject: Injecting strings and bools --- src/jscomp.sml | 16 +++++++++++++++- tests/jsinj.ur | 16 ++++++++++++++++ 2 files changed, 31 insertions(+), 1 deletion(-) diff --git a/src/jscomp.sml b/src/jscomp.sml index ca6508a9..d7017a47 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -162,10 +162,24 @@ fun process file = (EFfiApp ("Basis", "htmlifyInt", [e]), loc)] | TRecord [] => str loc "null" - | TFfi ("Basis", "string") => e + | TFfi ("Basis", "string") => (EFfiApp ("Basis", "jsifyString", [e]), loc) | TFfi ("Basis", "int") => (EFfiApp ("Basis", "htmlifyInt", [e]), loc) | TFfi ("Basis", "float") => (EFfiApp ("Basis", "htmlifyFloat", [e]), loc) + | TFfi ("Basis", "bool") => (ECase (e, + [((PCon (Enum, PConFfi {mod = "Basis", + datatyp = "bool", + con = "True", + arg = NONE}, NONE), loc), + str loc "true"), + ((PCon (Enum, PConFfi {mod = "Basis", + datatyp = "bool", + con = "False", + arg = NONE}, NONE), loc), + str loc "false")], + {disc = (TFfi ("Basis", "bool"), loc), + result = (TFfi ("Basis", "string"), loc)}), 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") diff --git a/tests/jsinj.ur b/tests/jsinj.ur index d5bd7dbb..bd416720 100644 --- a/tests/jsinj.ur +++ b/tests/jsinj.ur @@ -5,6 +5,8 @@ fun getOpt (t ::: Type) (o : option t) (v : t) : t = cookie int : int cookie float : float +cookie string : string +cookie bool : bool fun main () : transaction page = n <- getCookie int; @@ -15,10 +17,24 @@ fun main () : transaction page = f <- return (getOpt f 1.23); sf <- source 4.56; + s <- getCookie string; + s <- return (getOpt s "Hi"); + ss <- source "Bye"; + + b <- getCookie bool; + b <- return (getOpt b True); + sb <- source False; + return {[n]}}/> CHANGE
    {[f]}}/> CHANGE
    + + {[s]}}/> + CHANGE
    + + {[b]}}/> + CHANGE
    -- cgit v1.2.3 From 5b54ae6f4d5896428cdab7b213471498fa8a0b8a Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 2 Jan 2009 12:42:39 -0500 Subject: Injected a record --- src/jscomp.sml | 83 ++++++++++++++++++++++++++++++++++++++++------------------ tests/jsinj.ur | 8 ++++++ 2 files changed, 65 insertions(+), 26 deletions(-) diff --git a/src/jscomp.sml b/src/jscomp.sml index d7017a47..44012a4f 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -156,33 +156,60 @@ fun process file = fun str loc s = (EPrim (Prim.String s), loc) - fun quoteExp loc (t : typ) e = + fun quoteExp loc (t : typ) (e, st) = case #1 t of - TSource => strcat loc [str loc "s", - (EFfiApp ("Basis", "htmlifyInt", [e]), loc)] - | TRecord [] => str loc "null" - - | TFfi ("Basis", "string") => (EFfiApp ("Basis", "jsifyString", [e]), loc) - | TFfi ("Basis", "int") => (EFfiApp ("Basis", "htmlifyInt", [e]), loc) - | TFfi ("Basis", "float") => (EFfiApp ("Basis", "htmlifyFloat", [e]), loc) - - | TFfi ("Basis", "bool") => (ECase (e, - [((PCon (Enum, PConFfi {mod = "Basis", - datatyp = "bool", - con = "True", - arg = NONE}, NONE), loc), - str loc "true"), - ((PCon (Enum, PConFfi {mod = "Basis", - datatyp = "bool", - con = "False", - arg = NONE}, NONE), loc), - str loc "false")], - {disc = (TFfi ("Basis", "bool"), loc), - result = (TFfi ("Basis", "string"), loc)}), loc) + TSource => (strcat loc [str loc "s", + (EFfiApp ("Basis", "htmlifyInt", [e]), loc)], st) + + | TRecord [] => (str loc "null", st) + | TRecord [(x, t)] => + let + val (e, st) = quoteExp loc t ((EField (e, x), loc), st) + in + (strcat loc [str loc ("{_" ^ x ^ ":"), + e, + str loc "}"], st) + end + | TRecord ((x, t) :: xts) => + let + val (e', st) = quoteExp loc t ((EField (e, x), loc), st) + val (es, st) = ListUtil.foldlMap + (fn ((x, t), st) => + let + val (e, st) = quoteExp loc t ((EField (e, x), loc), st) + in + (strcat loc [str loc (",_" ^ x ^ ":"), e], st) + end) + st xts + in + (strcat loc (str loc ("{_" ^ x ^ ":") + :: e' + :: es + @ [str loc "}"]), st) + end + + | TFfi ("Basis", "string") => ((EFfiApp ("Basis", "jsifyString", [e]), loc), st) + | TFfi ("Basis", "int") => ((EFfiApp ("Basis", "htmlifyInt", [e]), loc), st) + | TFfi ("Basis", "float") => ((EFfiApp ("Basis", "htmlifyFloat", [e]), loc), st) + + | TFfi ("Basis", "bool") => ((ECase (e, + [((PCon (Enum, PConFfi {mod = "Basis", + datatyp = "bool", + con = "True", + arg = NONE}, NONE), loc), + str loc "true"), + ((PCon (Enum, PConFfi {mod = "Basis", + datatyp = "bool", + con = "False", + arg = NONE}, NONE), loc), + str loc "false")], + {disc = (TFfi ("Basis", "bool"), loc), + result = (TFfi ("Basis", "string"), loc)}), loc), + st) | _ => (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") + (str loc "ERROR", st)) fun jsExp mode skip outer = let @@ -318,7 +345,7 @@ fun process file = let val n = n - inner in - (quoteExp (List.nth (outer, n)) (ERel (n - skip), loc), st) + quoteExp (List.nth (outer, n)) ((ERel (n - skip), loc), st) end | ENamed n => @@ -507,8 +534,12 @@ fun process file = | ECase (e', pes, {result, ...}) => if closedUpto inner e andalso List.all (fn (_, e) => closedUpto inner e) pes then - ((ELet ("js", result, e, quoteExp result (ERel 0, loc)), loc), - st) + let + val (e', st) = quoteExp result ((ERel 0, loc), st) + in + ((ELet ("js", result, e, e'), loc), + st) + end else let val plen = length pes diff --git a/tests/jsinj.ur b/tests/jsinj.ur index bd416720..d9e09fb5 100644 --- a/tests/jsinj.ur +++ b/tests/jsinj.ur @@ -7,6 +7,7 @@ cookie int : int cookie float : float cookie string : string cookie bool : bool +cookie pair : int * float fun main () : transaction page = n <- getCookie int; @@ -25,6 +26,10 @@ fun main () : transaction page = b <- return (getOpt b True); sb <- source False; + p <- getCookie pair; + p <- return (getOpt p (1, 2.3)); + sp <- source (4, 5.6); + return {[n]}}/> CHANGE
    @@ -37,4 +42,7 @@ fun main () : transaction page = {[b]}}/> CHANGE
    + + {[p.1]}, {[p.2]}}/> + CHANGE
    -- cgit v1.2.3 From 06334cca38dfb430071426e79c98c685b7d53a8c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 2 Jan 2009 13:03:22 -0500 Subject: Injected an option --- src/jscomp.sml | 44 +++++++++++++++++++++++++++++++++----------- tests/jsinj.ur | 10 ++++++++++ 2 files changed, 43 insertions(+), 11 deletions(-) diff --git a/src/jscomp.sml b/src/jscomp.sml index 44012a4f..270dedf8 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -156,6 +156,12 @@ fun process file = fun str loc s = (EPrim (Prim.String s), loc) + fun isNullable (t, _) = + case t of + TOption _ => true + | TRecord [] => true + | _ => false + fun quoteExp loc (t : typ) (e, st) = case #1 t of TSource => (strcat loc [str loc "s", @@ -207,6 +213,23 @@ fun process file = result = (TFfi ("Basis", "string"), loc)}), loc), st) + | TOption t => + let + val (e', st) = quoteExp loc t ((ERel 0, loc), st) + in + ((ECase (e, + [((PNone t, loc), + str loc "null"), + ((PSome (t, (PVar ("x", t), loc)), loc), + if isNullable t then + strcat loc [str loc "{v:", e', str loc "}"] + else + e')], + {disc = (TOption t, loc), + result = (TFfi ("Basis", "string"), loc)}), loc), + st) + end + | _ => (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", st)) @@ -228,12 +251,6 @@ fun process file = | PConFfi {mod = "Basis", con = "False", ...} => str "false" | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"") - fun isNullable (t, _) = - case t of - TOption _ => true - | TRecord [] => true - | _ => false - fun unsupported s = (EM.errorAt loc (s ^ " in code to be compiled to JavaScript[2]"); (str "ERROR", st)) @@ -320,11 +337,16 @@ fun process file = str ":", succ, str ")"] - | PSome (_, p) => strcat [str ("(d" ^ Int.toString depth ^ "?"), - jsPat depth inner p succ fail, - str ":", - fail, - str ")"] + | PSome (t, p) => strcat (str ("(d" ^ Int.toString depth ^ "?") + :: (if isNullable t then + [str ("d" ^ Int.toString depth + ^ "=d" ^ Int.toString depth ^ ".v")] + else + []) + @ [jsPat depth inner p succ fail, + str ":", + fail, + str ")"]) fun deStrcat (e, _) = case e of diff --git a/tests/jsinj.ur b/tests/jsinj.ur index d9e09fb5..632a2839 100644 --- a/tests/jsinj.ur +++ b/tests/jsinj.ur @@ -8,6 +8,7 @@ cookie float : float cookie string : string cookie bool : bool cookie pair : int * float +cookie option : option int fun main () : transaction page = n <- getCookie int; @@ -30,6 +31,10 @@ fun main () : transaction page = p <- return (getOpt p (1, 2.3)); sp <- source (4, 5.6); + o <- getCookie option; + o <- return (getOpt o (Some 1)); + op <- source None; + return {[n]}}/> CHANGE
    @@ -45,4 +50,9 @@ fun main () : transaction page = {[p.1]}, {[p.2]}}/> CHANGE
    + + return None + | Some x => return {[x]}}/> + CHANGE
    -- cgit v1.2.3 From 21118ae45de71e6d1c144064ed09d136466d8a4f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 8 Jan 2009 09:57:45 -0500 Subject: Injected an enumeration --- src/jscomp.sml | 77 +++++++++++++++++++++++++++++++++++++++++++++++++--------- tests/jsinj.ur | 24 +++++++++++++++--- 2 files changed, 87 insertions(+), 14 deletions(-) diff --git a/src/jscomp.sml b/src/jscomp.sml index 270dedf8..1ae14e1a 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -58,7 +58,9 @@ fun ffi k = FM.find (funcs, k) type state = { decls : decl list, script : string list, - included : IS.set + included : IS.set, + injectors : int IM.map, + maxName : int } fun varDepth (e, _) = @@ -147,12 +149,13 @@ fun strcat loc es = fun process file = let - val nameds = foldl (fn ((DVal (_, n, t, e, _), _), nameds) => IM.insert (nameds, n, e) - | ((DValRec vis, _), nameds) => - foldl (fn ((_, n, _, e, _), nameds) => IM.insert (nameds, n, e)) - nameds vis - | (_, nameds) => nameds) - IM.empty file + val nameds = + foldl (fn ((DVal (_, n, t, e, _), _), nameds) => IM.insert (nameds, n, e) + | ((DValRec vis, _), nameds) => + foldl (fn ((_, n, _, e, _), nameds) => IM.insert (nameds, n, e)) + nameds vis + | (_, state) => state) + IM.empty file fun str loc s = (EPrim (Prim.String s), loc) @@ -230,6 +233,50 @@ fun process file = st) end + | TDatatype (n, ref (dk, cs)) => + (case IM.find (#injectors st, n) of + SOME n' => ((EApp ((ENamed n', loc), e), loc), st) + | NONE => + let + val dk = ElabUtil.classifyDatatype cs + + val n' = #maxName st + val st = {decls = #decls st, + script = #script st, + included = #included st, + injectors = IM.insert (#injectors st, n, n'), + maxName = n' + 1} + + val (pes, st) = ListUtil.foldlMap + (fn ((_, cn, NONE), st) => + (((PCon (dk, PConVar cn, NONE), loc), + str loc (Int.toString cn)), + st) + | ((_, cn, SOME t), st) => + let + val (e, st) = quoteExp loc t ((ERel 0, loc), st) + in + (((PCon (dk, PConVar cn, SOME (PVar ("x", t), loc)), loc), + e), + st) + end) + st cs + + val s = (TFfi ("Basis", "string"), loc) + val body = (ECase ((ERel 0, loc), pes, + {disc = t, result = s}), loc) + val body = (EAbs ("x", t, s, body), loc) + + val st = {decls = (DValRec [("jsify", n', (TFun (t, s), loc), + body, "jsify")], loc) :: #decls st, + script = #script st, + included = #included st, + injectors = #injectors st, + maxName = #maxName st} + in + ((EApp ((ENamed n', loc), e), loc), st) + end) + | _ => (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", st)) @@ -382,7 +429,9 @@ fun process file = let val st = {decls = #decls st, script = #script st, - included = IS.add (#included st, n)} + included = IS.add (#included st, n), + injectors = #injectors st, + maxName = #maxName st} val (e, st) = jsExp mode skip [] 0 (e, st) val e = deStrcat e @@ -391,7 +440,9 @@ fun process file = in {decls = #decls st, script = sc :: #script st, - included = #included st} + included = #included st, + injectors = #injectors st, + maxName = #maxName st} end in (str ("_n" ^ Int.toString n), st) @@ -717,13 +768,17 @@ fun process file = (List.revAppend (#decls st, [d]), {decls = [], script = #script st, - included = #included st}) + included = #included st, + injectors = #injectors st, + maxName = #maxName st}) end val (ds, st) = ListUtil.foldlMapConcat doDecl {decls = [], script = [], - included = IS.empty} + included = IS.empty, + injectors = IM.empty, + maxName = U.File.maxName file + 1} file val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.libJs, file = "urweb.js"}) diff --git a/tests/jsinj.ur b/tests/jsinj.ur index 632a2839..518748d8 100644 --- a/tests/jsinj.ur +++ b/tests/jsinj.ur @@ -3,12 +3,23 @@ fun getOpt (t ::: Type) (o : option t) (v : t) : t = None => v | Some x => x +datatype color = Red | White | Blue + +fun colorToString c = + case c of + Red => "R" + | White => "W" + | Blue => "B" + +val show_color = mkShow colorToString + cookie int : int cookie float : float cookie string : string cookie bool : bool cookie pair : int * float cookie option : option int +cookie color : color fun main () : transaction page = n <- getCookie int; @@ -33,7 +44,11 @@ fun main () : transaction page = o <- getCookie option; o <- return (getOpt o (Some 1)); - op <- source None; + so <- source None; + + c <- getCookie color; + c <- return (getOpt c White); + sc <- source Blue; return {[n]}}/> @@ -51,8 +66,11 @@ fun main () : transaction page = {[p.1]}, {[p.2]}}/> CHANGE
    - return None | Some x => return {[x]}}/> - CHANGE
    + CHANGE
    + + {[c]}}/> + CHANGE
    -- cgit v1.2.3 From 4b109c964ac7f433b4feb9d28b135dee28f75b87 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 8 Jan 2009 10:15:45 -0500 Subject: Injected a polymorphic, recursive type --- src/jscomp.sml | 70 +++++++++++++++++++++++++++++++++++++++++++++++++++------- tests/jsinj.ur | 15 +++++++++++++ 2 files changed, 77 insertions(+), 8 deletions(-) diff --git a/src/jscomp.sml b/src/jscomp.sml index 1ae14e1a..bb457ab3 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -149,13 +149,20 @@ fun strcat loc es = fun process file = let - val nameds = - foldl (fn ((DVal (_, n, t, e, _), _), nameds) => IM.insert (nameds, n, e) - | ((DValRec vis, _), nameds) => - foldl (fn ((_, n, _, e, _), nameds) => IM.insert (nameds, n, e)) - nameds vis + val (someTs, nameds) = + foldl (fn ((DVal (_, n, t, e, _), _), (someTs, nameds)) => (someTs, IM.insert (nameds, n, e)) + | ((DValRec vis, _), (someTs, nameds)) => + (someTs, foldl (fn ((_, n, _, e, _), nameds) => IM.insert (nameds, n, e)) + nameds vis) + | ((DDatatype (_, _, cs), _), state as (someTs, nameds)) => + if ElabUtil.classifyDatatype cs = Option then + (foldl (fn ((_, n, SOME t), someTs) => IM.insert (someTs, n, t) + | (_, someTs) => someTs) someTs cs, + nameds) + else + state | (_, state) => state) - IM.empty file + (IM.empty, IM.empty) file fun str loc s = (EPrim (Prim.String s), loc) @@ -250,14 +257,24 @@ fun process file = val (pes, st) = ListUtil.foldlMap (fn ((_, cn, NONE), st) => (((PCon (dk, PConVar cn, NONE), loc), - str loc (Int.toString cn)), + case dk of + Option => str loc "null" + | _ => str loc (Int.toString cn)), st) | ((_, cn, SOME t), st) => let val (e, st) = quoteExp loc t ((ERel 0, loc), st) in (((PCon (dk, PConVar cn, SOME (PVar ("x", t), loc)), loc), - e), + case dk of + Option => + if isNullable t then + strcat loc [str loc "{_v:", + e, + str loc "}"] + else + e + | _ => e), st) end) st cs @@ -350,6 +367,26 @@ fun process file = str ":", succ, str ")"] + | PCon (Option, _, NONE) => + strcat [str ("(d" ^ Int.toString depth ^ "?"), + fail, + str ":", + succ, + str ")"] + | PCon (Option, PConVar n, SOME p) => + (case IM.find (someTs, n) of + NONE => raise Fail "Jscomp: Not in someTs" + | SOME t => + strcat [str ("(d" ^ Int.toString depth ^ "?(" + ^ (if isNullable t then + "d" ^ Int.toString depth ^ "=d" + ^ Int.toString depth ^ ".v," + else + "")), + jsPat depth inner p succ fail, + str "):", + fail, + str ")"]) | PCon (_, pc, NONE) => strcat [str ("(d" ^ Int.toString depth ^ "=="), patCon pc, @@ -448,6 +485,22 @@ fun process file = (str ("_n" ^ Int.toString n), st) end + | ECon (Option, _, NONE) => (str "null", st) + | ECon (Option, PConVar n, SOME e) => + let + val (e, st) = jsE inner (e, st) + in + case IM.find (someTs, n) of + NONE => raise Fail "Jscomp: Not in someTs [2]" + | SOME t => + (if isNullable t then + strcat [str "{v:", + e, + str "}"] + else + e, st) + end + | ECon (_, pc, NONE) => (patCon pc, st) | ECon (_, pc, SOME e) => let @@ -459,6 +512,7 @@ fun process file = s, str "}"], st) end + | ENone _ => (str "null", st) | ESome (t, e) => let diff --git a/tests/jsinj.ur b/tests/jsinj.ur index 518748d8..f3954085 100644 --- a/tests/jsinj.ur +++ b/tests/jsinj.ur @@ -13,6 +13,13 @@ fun colorToString c = val show_color = mkShow colorToString +datatype list a = Nil | Cons of a * list a + +fun delist ls : xbody = + case ls of + Nil => Nil + | Cons (h, t) => {cdata h} :: {delist t} + cookie int : int cookie float : float cookie string : string @@ -20,6 +27,7 @@ cookie bool : bool cookie pair : int * float cookie option : option int cookie color : color +cookie list : list string fun main () : transaction page = n <- getCookie int; @@ -50,6 +58,10 @@ fun main () : transaction page = c <- return (getOpt c White); sc <- source Blue; + l <- getCookie list; + l <- return (getOpt l (Cons ("A", Cons ("B", Nil)))); + sl <- source Nil; + return {[n]}}/> CHANGE
    @@ -73,4 +85,7 @@ fun main () : transaction page = {[c]}}/> CHANGE
    + + {delist l}}/> + CHANGE
    -- cgit v1.2.3 From 9608c763d7b2923c11e8abd29e28271ae470a5fe Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 8 Jan 2009 10:30:14 -0500 Subject: Injected a non-special-case datatype --- jslib/urweb.js | 4 ++++ src/jscomp.sml | 7 +++++-- tests/jsinj.ur | 18 ++++++++++++++++++ 3 files changed, 27 insertions(+), 2 deletions(-) diff --git a/jslib/urweb.js b/jslib/urweb.js index 16424eb3..9d28b461 100644 --- a/jslib/urweb.js +++ b/jslib/urweb.js @@ -41,6 +41,10 @@ function dyn(s) { s.h = cons(function() { x.innerHTML = s.v }, s.h); } +function eh(x) { + return x.split("&").join("&").split("<").join("<").split(">").join(">"); +} + function ts(x) { return x.toString() } function bs(b) { return (b ? "True" : "False") } diff --git a/src/jscomp.sml b/src/jscomp.sml index bb457ab3..64cb1771 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -40,7 +40,7 @@ val funcs = [(("Basis", "alert"), "alert"), (("Basis", "htmlifyBool"), "bs"), (("Basis", "htmlifyFloat"), "ts"), (("Basis", "htmlifyInt"), "ts"), - (("Basis", "htmlifyString"), "escape"), + (("Basis", "htmlifyString"), "eh"), (("Basis", "new_client_source"), "sc"), (("Basis", "set_client_source"), "sv")] @@ -274,7 +274,10 @@ fun process file = str loc "}"] else e - | _ => e), + | _ => strcat loc [str loc ("{n:" ^ Int.toString cn + ^ ",v:"), + e, + str loc "}"]), st) end) st cs diff --git a/tests/jsinj.ur b/tests/jsinj.ur index f3954085..182de33b 100644 --- a/tests/jsinj.ur +++ b/tests/jsinj.ur @@ -20,6 +20,16 @@ fun delist ls : xbody = Nil => Nil | Cons (h, t) => {cdata h} :: {delist t} +datatype weird = Foo | Bar | Baz of string + +fun weirdToString w = + case w of + Foo => "Foo" + | Bar => "Bar" + | Baz s => s + +val show_weird = mkShow weirdToString + cookie int : int cookie float : float cookie string : string @@ -28,6 +38,7 @@ cookie pair : int * float cookie option : option int cookie color : color cookie list : list string +cookie weird : weird fun main () : transaction page = n <- getCookie int; @@ -62,6 +73,10 @@ fun main () : transaction page = l <- return (getOpt l (Cons ("A", Cons ("B", Nil)))); sl <- source Nil; + w <- getCookie weird; + w <- return (getOpt w (Baz "TADA!")); + sw <- source Foo; + return {[n]}}/> CHANGE
    @@ -88,4 +103,7 @@ fun main () : transaction page = {delist l}}/> CHANGE
    + + {[w]}}/> + CHANGE
    -- 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 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(-) 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 0d9b4b2f411af95f9a886a3b188f0b2c688be27b Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 11 Jan 2009 10:41:38 -0500 Subject: Do proper insertion of dynamic content within nested DOM containers --- jslib/urweb.js | 13 +++++++++++-- tests/ooo.ur | 8 ++++++++ tests/ooo.urp | 3 +++ 3 files changed, 22 insertions(+), 2 deletions(-) create mode 100644 tests/ooo.ur create mode 100644 tests/ooo.urp diff --git a/jslib/urweb.js b/jslib/urweb.js index 0f9c06cf..8e39f9f3 100644 --- a/jslib/urweb.js +++ b/jslib/urweb.js @@ -34,17 +34,26 @@ function sb(x,y) { return s; } +function myParent() { + var pos = document; + + while (pos.lastChild && pos.lastChild.nodeType == 1) + pos = pos.lastChild; + + return pos.parentNode; +} + function dyn(s) { var x = document.createElement("span"); x.innerHTML = s.v; - document.body.appendChild(x); + myParent().appendChild(x); 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); + myParent().appendChild(x); s.h = cons(function() { x.value = s.v }, s.h); x.onkeyup = function() { sv(s, x.value) }; } diff --git a/tests/ooo.ur b/tests/ooo.ur new file mode 100644 index 00000000..5401fa70 --- /dev/null +++ b/tests/ooo.ur @@ -0,0 +1,8 @@ +fun main () : transaction page = + s <- source "Hi"; + return +
    + + Change it up! + +
    diff --git a/tests/ooo.urp b/tests/ooo.urp new file mode 100644 index 00000000..5a510107 --- /dev/null +++ b/tests/ooo.urp @@ -0,0 +1,3 @@ +debug + +ooo -- 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 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 +
    +
    + + +     + -- cgit v1.2.3 From 2bd5faedfe7464c9f4cc6bd36084d487c7c86b2a Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 19 Aug 2014 11:08:25 -0400 Subject: New release --- CHANGELOG | 7 +++++++ configure.ac | 4 ++-- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index b80c8d9f..e56e24db 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,10 @@ +======== +20140819 +======== + +- Improvements to HTML model +- Bug fixes and optimization improvements + ======== 20140807 ======== diff --git a/configure.ac b/configure.ac index 25698b7f..e0f795e1 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ -AC_INIT([urweb], [20140807]) -WORKING_VERSION=1 +AC_INIT([urweb], [20140819]) +WORKING_VERSION=0 AC_USE_SYSTEM_EXTENSIONS # automake 1.12 requires this, but automake 1.11 doesn't recognize it -- cgit v1.2.3 From 277913f2ae39e159b1a639fe1d869fd00ce1a2c7 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 19 Aug 2014 11:17:39 -0400 Subject: and type fixes (grandfathered into release) --- lib/ur/basis.urs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 9d58ee66..30271ce9 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -1019,9 +1019,8 @@ val button : cformTag ([Value = string] ++ boxAttrs) [] val ccheckbox : cformTag ([Value = bool, Size = int, Source = source bool, Onchange = transaction unit] ++ boxAttrs) [] -con cselect = [Cselect] -val cselect : cformTag ([Source = source string, Onchange = transaction unit] ++ boxAttrs) cselect -val coption : unit -> tag [Value = string, Selected = bool] cselect [] [] [] +val cselect : cformTag ([Source = source string, Onchange = transaction unit] ++ boxAttrs) [Cselect] +val coption : unit -> tag [Value = string, Selected = bool] [Cselect, Body] [] [] [] val ctextarea : cformTag ([Value = string, Rows = int, Cols = int, Source = source string, Onchange = transaction unit, Ontext = transaction unit] ++ boxAttrs) [] -- cgit v1.2.3 From 9515ba96f8f48b17888267c15b3181893cca6be3 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 19 Aug 2014 11:23:26 -0400 Subject: Return to working version mode --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index e0f795e1..074c26cd 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ AC_INIT([urweb], [20140819]) -WORKING_VERSION=0 +WORKING_VERSION=1 AC_USE_SYSTEM_EXTENSIONS # automake 1.12 requires this, but automake 1.11 doesn't recognize it -- cgit v1.2.3 From cb0fdb4d2b0682d67fe57dc755b574d1867216b5 Mon Sep 17 00:00:00 2001 From: Sergey Mironov Date: Mon, 7 Jul 2014 10:05:04 +0400 Subject: Add 'role' data attribute. Note, that 'role' attribute is a part of reach ARIA API described here: http://www.w3.org/TR/wai-aria/ Among 'role', it defines lots of aria-* attributes --- lib/ur/basis.urs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 30271ce9..5d0a0c8a 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -848,7 +848,7 @@ con scrollEvents = [Onscroll = transaction unit] con boxEvents = focusEvents ++ mouseEvents ++ keyEvents ++ resizeEvents ++ scrollEvents con tableEvents = focusEvents ++ mouseEvents ++ keyEvents -con boxAttrs = [Data = data_attr, Id = id, Title = string] ++ boxEvents +con boxAttrs = [Data = data_attr, Id = id, Title = string, Role = string] ++ boxEvents con tableAttrs = [Data = data_attr, Id = id, Title = string] ++ tableEvents val span : bodyTag boxAttrs -- cgit v1.2.3 From cbe0e1aeceefc7db712230a070ddcf757cfe1981 Mon Sep 17 00:00:00 2001 From: Sergey Mironov Date: Sat, 23 Aug 2014 11:59:34 +0000 Subject: Check realloc's return code to prevent segfault on out of memoty condition --- src/c/request.c | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/src/c/request.c b/src/c/request.c index f212655f..9dc6aa59 100644 --- a/src/c/request.c +++ b/src/c/request.c @@ -444,8 +444,12 @@ request_result uw_request(uw_request_context rc, uw_context ctx, int len = strlen(inputs); if (len+1 > rc->queryString_size) { - rc->queryString_size = len+1; rc->queryString = realloc(rc->queryString, len+1); + if(rc->queryString == NULL) { + log_error(logger_data, "queryString is too long (not enough memory)\n"); + return FAILED; + } + rc->queryString_size = len+1; } strcpy(rc->queryString, inputs); @@ -480,8 +484,12 @@ request_result uw_request(uw_request_context rc, uw_context ctx, on_success(ctx); if (path_len + 1 > rc->path_copy_size) { + rc->path_copy = realloc(rc->path_copy, path_len + 1); + if(rc->path_copy == NULL) { + log_error(logger_data, "Path is too long (not enough memory)\n"); + return FAILED; + } rc->path_copy_size = path_len + 1; - rc->path_copy = realloc(rc->path_copy, rc->path_copy_size); } strcpy(rc->path_copy, path); -- cgit v1.2.3 From 0f24f4667d4571834c552d9a6ca3dbe180296bb0 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 24 Aug 2014 11:43:49 -0400 Subject: Extend ScriptCheck to take RPCs into account --- src/scriptcheck.sml | 101 ++++++++++++++++++++++++++++++++++++++++++++------- tests/DynChannel.ur | 29 +++++++++++++++ tests/DynChannel.urp | 6 +++ tests/rpchan.ur | 18 +++++++++ tests/rpchan.urs | 1 + 5 files changed, 142 insertions(+), 13 deletions(-) create mode 100644 tests/DynChannel.ur create mode 100644 tests/DynChannel.urp create mode 100644 tests/rpchan.ur create mode 100644 tests/rpchan.urs diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml index 4bc2a4cf..0d30ebcb 100644 --- a/src/scriptcheck.sml +++ b/src/scriptcheck.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2009, Adam Chlipala +(* Copyright (c) 2009, 2014, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -29,6 +29,10 @@ structure ScriptCheck :> SCRIPT_CHECK = struct open Mono +structure SM = BinaryMapFn(struct + type ord_key = string + val compare = String.compare + end) structure SS = BinarySetFn(struct type ord_key = string val compare = String.compare @@ -39,37 +43,108 @@ val pushBasis = SS.addList (SS.empty, ["new_channel", "self"]) +datatype rpcmap = + Rpc of int (* ID of function definition *) + | Module of rpcmap SM.map + +fun lookup (r : rpcmap, k : string) = + let + fun lookup' (r, ks) = + case r of + Rpc x => SOME x + | Module m => + case ks of + [] => NONE + | k :: ks' => + case SM.find (m, k) of + NONE => NONE + | SOME r' => lookup' (r', ks') + in + lookup' (r, String.tokens (fn ch => ch = #"/") k) + end + +fun insert (r : rpcmap, k : string, v) = + let + fun insert' (r, ks) = + case r of + Rpc _ => Rpc v + | Module m => + case ks of + [] => Rpc v + | k :: ks' => + let + val r' = case SM.find (m, k) of + NONE => Module SM.empty + | SOME r' => r' + in + Module (SM.insert (m, k, insert' (r', ks'))) + end + in + insert' (r, String.tokens (fn ch => ch = #"/") k) + end + +fun dump (r : rpcmap) = + case r of + Rpc _ => print "ROOT\n" + | Module m => (print "\n"; + SM.appi (fn (k, r') => (print (k ^ ":\n"); + dump r')) m; + print "\n") + fun classify (ds, ps) = let val proto = Settings.currentProtocol () fun inString {needle, haystack} = String.isSubstring needle haystack - fun hasClient {basis, funcs, push} = + fun hasClient {basis, rpcs, funcs, push} = MonoUtil.Exp.exists {typ = fn _ => false, exp = fn ERecv _ => push | EFfiApp ("Basis", x, _) => SS.member (basis, x) | EJavaScript _ => not push | ENamed n => IS.member (funcs, n) + | EServerCall (e, _, _, _) => + let + fun head (e : exp) = + case #1 e of + EStrcat (e1, _) => head e1 + | EPrim (Prim.String (_, s)) => SOME s + | _ => NONE + in + case head e of + NONE => true + | SOME fcall => + case lookup (rpcs, fcall) of + NONE => true + | SOME n => IS.member (funcs, n) + end | _ => false} + fun decl ((d, _), rpcs) = + case d of + DExport (Mono.Rpc _, fcall, n, _, _, _) => + insert (rpcs, fcall, n) + | _ => rpcs + + val rpcs = foldl decl (Module SM.empty) ds + fun decl ((d, _), (pull_ids, push_ids)) = let - val hasClientPull = hasClient {basis = SS.empty, funcs = pull_ids, push = false} - val hasClientPush = hasClient {basis = pushBasis, funcs = push_ids, push = true} + val hasClientPull = hasClient {basis = SS.empty, rpcs = rpcs, funcs = pull_ids, push = false} + val hasClientPush = hasClient {basis = pushBasis, rpcs = rpcs, funcs = push_ids, push = true} in case d of DVal (_, n, _, e, _) => (if hasClientPull e then - IS.add (pull_ids, n) - else - pull_ids, - if hasClientPush e then - IS.add (push_ids, n) - else - push_ids) + IS.add (pull_ids, n) + else + pull_ids, + if hasClientPush e then + IS.add (push_ids, n) + else + push_ids) | DValRec xes => (if List.exists (fn (_, _, _, e, _) => hasClientPull e) xes then - foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n)) - pull_ids xes + foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n)) + pull_ids xes else pull_ids, if List.exists (fn (_, _, _, e, _) => hasClientPush e) xes then diff --git a/tests/DynChannel.ur b/tests/DynChannel.ur new file mode 100644 index 00000000..d3688781 --- /dev/null +++ b/tests/DynChannel.ur @@ -0,0 +1,29 @@ +table channels : {Id : int, Channel:channel xbody} + +fun dosend (s:string) : transaction unit = + c <- oneRow1 (SELECT * FROM channels); + debug ("Sending " ^ s ^ " through the channel..."); + send c.Channel {[s]} + +fun mkchannel {} : transaction xbody = + c <- channel; + s <- source ; + dml( DELETE FROM channels WHERE Id >= 0); + dml( INSERT INTO channels(Id, Channel) VALUES(0, {[c]}) ); + return + + +
    + +     diff --git a/tests/rpchan.urs b/tests/rpchan.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/rpchan.urs @@ -0,0 +1 @@ +val main : unit -> transaction page -- cgit v1.2.3 From 4e4c43ff335cd6c2f1ec6bf359f69e9b09047572 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 30 Aug 2014 08:28:59 -0400 Subject: New release --- CHANGELOG | 7 +++++++ configure.ac | 4 ++-- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index e56e24db..979f4d87 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,10 @@ +======== +20140830 +======== + +- New HTML attribute: 'role' +- Bug fixes + ======== 20140819 ======== diff --git a/configure.ac b/configure.ac index 074c26cd..85ce1da5 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ -AC_INIT([urweb], [20140819]) -WORKING_VERSION=1 +AC_INIT([urweb], [20140830]) +WORKING_VERSION=0 AC_USE_SYSTEM_EXTENSIONS # automake 1.12 requires this, but automake 1.11 doesn't recognize it -- cgit v1.2.3 From 4fe4c6868a10db99ddadf4cd60576178df29c8cd Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 30 Aug 2014 08:48:41 -0400 Subject: Return to working version mode --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index 85ce1da5..2ff25580 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ AC_INIT([urweb], [20140830]) -WORKING_VERSION=0 +WORKING_VERSION=1 AC_USE_SYSTEM_EXTENSIONS # automake 1.12 requires this, but automake 1.11 doesn't recognize it -- cgit v1.2.3 From a894904947777bbc797a69b1d55ca4008375acaf Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 4 Sep 2014 08:40:14 -0400 Subject: In computing command lines, put filenames inside of quotes, to support spaces and other funky characters nicely --- src/compiler.sml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/compiler.sml b/src/compiler.sml index 716cc3d3..b46643ff 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2012, Adam Chlipala +(* Copyright (c) 2008-2012, 2014, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -1483,7 +1483,10 @@ val sqlify = { val toSqlify = transform sqlify "sqlify" o toMono_opt2 -val escapeFilename = String.translate (fn #" " => "\\ " | #"\"" => "\\\"" | #"'" => "\\'" | ch => str ch) +fun escapeFilename s = + "\"" + ^ String.translate (fn #"\"" => "\\\"" | #"\\" => "\\\\" | ch => str ch) s + ^ "\"" val beforeC = ref (fn () => ()) -- cgit v1.2.3 From 1bbc50639256f0a04b1866ad23a3945c17130068 Mon Sep 17 00:00:00 2001 From: Sergey Mironov Date: Sun, 24 Aug 2014 11:56:41 +0400 Subject: Check realloc's return code to prevent segfault on out of memory condition (Part 2) --- src/c/request.c | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/c/request.c b/src/c/request.c index 9dc6aa59..d621aea7 100644 --- a/src/c/request.c +++ b/src/c/request.c @@ -444,11 +444,12 @@ request_result uw_request(uw_request_context rc, uw_context ctx, int len = strlen(inputs); if (len+1 > rc->queryString_size) { - rc->queryString = realloc(rc->queryString, len+1); - if(rc->queryString == NULL) { + char *qs = realloc(rc->queryString, len+1); + if(qs == NULL) { log_error(logger_data, "queryString is too long (not enough memory)\n"); return FAILED; } + rc->queryString = qs; rc->queryString_size = len+1; } strcpy(rc->queryString, inputs); @@ -484,11 +485,12 @@ request_result uw_request(uw_request_context rc, uw_context ctx, on_success(ctx); if (path_len + 1 > rc->path_copy_size) { - rc->path_copy = realloc(rc->path_copy, path_len + 1); - if(rc->path_copy == NULL) { + char *pc = realloc(rc->path_copy, path_len + 1); + if(pc == NULL) { log_error(logger_data, "Path is too long (not enough memory)\n"); return FAILED; } + rc->path_copy = pc; rc->path_copy_size = path_len + 1; } strcpy(rc->path_copy, path); -- cgit v1.2.3 From c833454d70e5ae0436ed495f886209f95e07329e Mon Sep 17 00:00:00 2001 From: Sergey Mironov Date: Tue, 2 Sep 2014 17:36:14 +0000 Subject: Replace common "if(!quiet) printf(...)" pattern with a macro --- src/c/http.c | 30 ++++++++++++------------------ 1 file changed, 12 insertions(+), 18 deletions(-) diff --git a/src/c/http.c b/src/c/http.c index 32dd1dd1..2e419f05 100644 --- a/src/c/http.c +++ b/src/c/http.c @@ -23,6 +23,9 @@ extern uw_app uw_application; int uw_backlog = SOMAXCONN; static int keepalive = 0, quiet = 0; +#define qfprintf(f, fmt, args...) do { if(!quiet) fprintf(f, fmt, ##args); } while(0) +#define qprintf(fmt, args...) do { if(!quiet) printf(fmt, ##args); } while(0) + static char *get_header(void *data, const char *h) { char *s = data; int len = strlen(h); @@ -86,8 +89,7 @@ static void *worker(void *data) { sock = uw_dequeue(); } - if (!quiet) - printf("Handling connection with thread #%d.\n", me); + qprintf("Handling connection with thread #%d.\n", me); while (1) { int r; @@ -107,16 +109,14 @@ static void *worker(void *data) { r = recv(sock, back, buf_size - 1 - (back - buf), 0); if (r < 0) { - if (!quiet) - fprintf(stderr, "Recv failed\n"); + qfprintf(stderr, "Recv failed while receiving header\n"); close(sock); sock = 0; break; } if (r == 0) { - if (!quiet) - printf("Connection closed.\n"); + qprintf("Connection closed.\n"); close(sock); sock = 0; break; @@ -159,16 +159,14 @@ static void *worker(void *data) { r = recv(sock, back, buf_size - 1 - (back - buf), 0); if (r < 0) { - if (!quiet) - fprintf(stderr, "Recv failed\n"); + qfprintf(stderr, "Recv failed\n"); close(sock); sock = 0; goto done; } if (r == 0) { - if (!quiet) - fprintf(stderr, "Connection closed.\n"); + qfprintf(stderr, "Connection closed.\n"); close(sock); sock = 0; goto done; @@ -236,8 +234,7 @@ static void *worker(void *data) { uw_set_headers(ctx, get_header, headers); uw_set_env(ctx, get_env, NULL); - if (!quiet) - printf("Serving URI %s....\n", path); + qprintf("Serving URI %s....\n", path); rr = uw_request(rc, ctx, method, path, query_string, body, back - body, on_success, on_failure, NULL, log_error, log_debug, @@ -405,8 +402,7 @@ int main(int argc, char *argv[]) { sin_size = sizeof their_addr; - if (!quiet) - printf("Listening on port %d....\n", uw_port); + qprintf("Listening on port %d....\n", uw_port); { pthread_t thread; @@ -434,11 +430,9 @@ int main(int argc, char *argv[]) { int new_fd = accept(sockfd, (struct sockaddr *)&their_addr, &sin_size); if (new_fd < 0) { - if (!quiet) - fprintf(stderr, "Socket accept failed\n"); + qfprintf(stderr, "Socket accept failed\n"); } else { - if (!quiet) - printf("Accepted connection.\n"); + qprintf("Accepted connection.\n"); if (keepalive) { int flag = 1; -- cgit v1.2.3 From af2946386863bcb273aa2677a3d6e235d1660b16 Mon Sep 17 00:00:00 2001 From: Sergey Mironov Date: Tue, 2 Sep 2014 17:37:22 +0000 Subject: Check realloc's return code to prevent segfault on out of memory condition (Part 3) --- src/c/http.c | 24 +++++++++++++++++++----- 1 file changed, 19 insertions(+), 5 deletions(-) diff --git a/src/c/http.c b/src/c/http.c index 2e419f05..2a8b7e94 100644 --- a/src/c/http.c +++ b/src/c/http.c @@ -97,8 +97,15 @@ static void *worker(void *data) { if (back - buf == buf_size - 1) { char *new_buf; - buf_size *= 2; - new_buf = realloc(buf, buf_size); + size_t new_buf_size = buf_size*2; + new_buf = realloc(buf, new_buf_size); + if(!new_buf) { + qfprintf(stderr, "Realloc failed while receiving header\n"); + close(sock); + sock = 0; + break; + } + buf_size = new_buf_size; back = new_buf + (back - buf); buf = new_buf; } @@ -146,9 +153,16 @@ static void *worker(void *data) { while (back - body < clen) { if (back - buf == buf_size - 1) { char *new_buf; - buf_size *= 2; - new_buf = realloc(buf, buf_size); - + size_t new_buf_size = buf_size * 2; + new_buf = realloc(buf, new_buf_size); + if(!new_buf) { + qfprintf(stderr, "Realloc failed while receiving content\n"); + close(sock); + sock = 0; + goto done; + } + + buf_size = new_buf_size; back = new_buf + (back - buf); body = new_buf + (body - buf); s = new_buf + (s - buf); -- cgit v1.2.3 From 5d2d4930568267b0e205ece3d4908cdc7ff715a1 Mon Sep 17 00:00:00 2001 From: Sergey Mironov Date: Tue, 2 Sep 2014 17:42:10 +0000 Subject: Introduce recv timeout controlled by '-T' option in http.c This should prevent a DDoS attack where attacker and keeps the connection open but send no data. --- src/c/http.c | 29 +++++++++++++++++++++++++---- 1 file changed, 25 insertions(+), 4 deletions(-) diff --git a/src/c/http.c b/src/c/http.c index 2a8b7e94..9651a216 100644 --- a/src/c/http.c +++ b/src/c/http.c @@ -116,7 +116,7 @@ static void *worker(void *data) { r = recv(sock, back, buf_size - 1 - (back - buf), 0); if (r < 0) { - qfprintf(stderr, "Recv failed while receiving header\n"); + qfprintf(stderr, "Recv failed while receiving header, retcode %d errno %m\n", r); close(sock); sock = 0; break; @@ -173,7 +173,7 @@ static void *worker(void *data) { r = recv(sock, back, buf_size - 1 - (back - buf), 0); if (r < 0) { - qfprintf(stderr, "Recv failed\n"); + qfprintf(stderr, "Recv failed while receiving content, retcode %d errno %m\n", r); close(sock); sock = 0; goto done; @@ -312,7 +312,7 @@ static void *worker(void *data) { } static void help(char *cmd) { - printf("Usage: %s [-p ] [-a ] [-t ] [-k] [-q]\nThe '-k' option turns on HTTP keepalive.\nThe '-q' option turns off some chatter on stdout.\n", cmd); + printf("Usage: %s [-p ] [-a ] [-t ] [-k] [-q] [-T SEC]\nThe '-k' option turns on HTTP keepalive.\nThe '-q' option turns off some chatter on stdout.\nThe -T option sets socket recv timeout (0 disables timeout, default is 5 sec)", cmd); } static void sigint(int signum) { @@ -327,6 +327,7 @@ int main(int argc, char *argv[]) { struct sockaddr_in their_addr; // connector's address information socklen_t sin_size; int yes = 1, uw_port = 8080, nthreads = 1, i, *names, opt; + int recv_timeout_sec = 5; signal(SIGINT, sigint); signal(SIGPIPE, SIG_IGN); @@ -334,7 +335,7 @@ int main(int argc, char *argv[]) { my_addr.sin_addr.s_addr = INADDR_ANY; // auto-fill with my IP memset(my_addr.sin_zero, '\0', sizeof my_addr.sin_zero); - while ((opt = getopt(argc, argv, "hp:a:t:kq")) != -1) { + while ((opt = getopt(argc, argv, "hp:a:t:kqT:")) != -1) { switch (opt) { case '?': fprintf(stderr, "Unknown command-line option\n"); @@ -375,6 +376,15 @@ int main(int argc, char *argv[]) { keepalive = 1; break; + case 'T': + recv_timeout_sec = atoi(optarg); + if (recv_timeout_sec < 0) { + fprintf(stderr, "Invalid recv timeout\n"); + help(argv[0]); + return 1; + } + break; + case 'q': quiet = 1; break; @@ -453,6 +463,17 @@ int main(int argc, char *argv[]) { setsockopt(new_fd, IPPROTO_TCP, TCP_NODELAY, (char *) &flag, sizeof(int)); } + if(recv_timeout_sec>0) { + int ret; + struct timeval tv; + memset(&tv, 0, sizeof(struct timeval)); + tv.tv_sec = recv_timeout_sec; + ret = setsockopt(new_fd, SOL_SOCKET, SO_RCVTIMEO, (char *)&tv, sizeof(struct timeval)); + if(ret != 0) { + qfprintf(stderr, "Timeout setting failed, errcode %d errno '%m'\n", ret); + } + } + uw_enqueue(new_fd); } } -- cgit v1.2.3 From 8cf3a275f25ffcbb97d623c4e988fdcc81ef5978 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Mon, 15 Sep 2014 20:01:16 -0400 Subject: Small cleanup. --- caching-tests/test.db | Bin 3072 -> 3072 bytes src/cjr_print.sml | 14 ++++++----- src/sql.sig | 6 +---- src/sqlcache.sml | 67 +++++++++++++++++++++++++------------------------- 4 files changed, 42 insertions(+), 45 deletions(-) diff --git a/caching-tests/test.db b/caching-tests/test.db index 190d2868..a5c91e8f 100644 Binary files a/caching-tests/test.db and b/caching-tests/test.db differ diff --git a/src/cjr_print.sml b/src/cjr_print.sml index b2e8d2a7..8ca35234 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3393,7 +3393,7 @@ fun p_file env (ds, ps) = newline, newline, - (* For caching. *) + (* For sqlcache. *) box (List.map (fn index => let val i = Int.toString index @@ -3403,19 +3403,21 @@ fun p_file env (ds, ps) = newline, string "static uw_Basis_bool uw_Cache_check", string i, - string "(uw_context ctx) { puts(\"Checked cache ", + string "(uw_context ctx) { puts(\"SQLCACHE: checked ", string i, string ".\"); if (cache", string i, string " == NULL) { uw_recordingStart(ctx); return uw_Basis_False; } else { uw_write(ctx, cache", string i, - string "); return uw_Basis_True; } };", + string "); puts(\"SQLCACHE: used ", + string i, + string ".\"); return uw_Basis_True; } };", newline, string "static uw_unit uw_Cache_store", string i, string "(uw_context ctx) { cache", string i, - string " = uw_recordingRead(ctx); puts(\"Stored cache ", + string " = uw_recordingRead(ctx); puts(\"SQLCACHE: stored ", string i, string ".\"); return uw_unit_v; };", newline, @@ -3425,7 +3427,7 @@ fun p_file env (ds, ps) = string i, string "); cache", string i, - string " = NULL; puts(\"Flushed cache ", + string " = NULL; puts(\"SQLCACHE: flushed ", string i, string ".\"); return uw_unit_v; };", newline, @@ -3564,7 +3566,7 @@ fun p_file env (ds, ps) = newline, string ("uw_write_header(ctx, \"Content-Length: " ^ Int.toString (Word8Vector.length (#Bytes r)) ^ "\\r\\n\");"), newline, - string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"), + string ("uw_write_header(ctx, \"Cache-Control: max-age=31536000, public\\r\\n\");"), newline, string "uw_replace_page(ctx, \"", string (hexify (#Bytes r)), diff --git a/src/sql.sig b/src/sql.sig index 573a8baf..2623f5e7 100644 --- a/src/sql.sig +++ b/src/sql.sig @@ -39,11 +39,7 @@ datatype prop = | Reln of reln * exp list | Cond of exp * prop -datatype chunk = - String of string - | Exp of Mono.exp - -type 'a parser = chunk list -> ('a * chunk list) option +type 'a parser val parse : 'a parser -> Mono.exp -> 'a option diff --git a/src/sqlcache.sml b/src/sqlcache.sml index 2e7f6e42..b01de4c9 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -12,6 +12,37 @@ structure SIMM = MultimapFn (structure KeyMap = SM structure ValSet = IS) val ffiIndices : int list ref = ref [] +(* Expression construction utilities. *) + +fun intExp (n, loc) = (EPrim (Prim.Int (Int64.fromInt n)), loc) +fun intTyp loc = (TFfi ("Basis", "int"), loc) +fun boolPat (b, loc) = (PCon (Enum, + PConFfi {mod = "Basis", datatyp = "bool", arg = NONE, + con = if b then "True" else "False"}, + NONE), + loc) +fun boolTyp loc = (TFfi ("Basis", "int"), loc) + +fun ffiAppExp (module, func, index, loc) = + (EFfiApp (module, func ^ Int.toString index, []), loc) + +fun sequence ((exp :: exps), loc) = + List.foldl (fn (exp, seq) => (ESeq (seq, exp), loc)) exp exps + +fun antiguardUnit (cond, exp, loc) = + (ECase (cond, + [(boolPat (false, loc), exp), + (boolPat (true, loc), (ERecord [], loc))], + {disc = boolTyp loc, result = (TRecord [], loc)}), + loc) + +fun underAbs f (exp as (exp', loc)) = + case exp' of + EAbs (x, y, z, body) => (EAbs (x, y, z, underAbs f body), loc) + | _ => f exp + +(* Program analysis and augmentation. *) + val rec tablesRead = fn Query1 {From=tablePairs, ...} => SS.fromList (map #1 tablePairs) | Union (q1,q2) => SS.union (tablesRead q1, tablesRead q2) @@ -47,37 +78,6 @@ val tablesInExp = {read = SS.empty, written = SS.empty} end -fun intExp (n, loc) = (EPrim (Prim.Int (Int64.fromInt n)), loc) -fun intTyp loc = (TFfi ("Basis", "int"), loc) -fun boolPat (b, loc) = (PCon (Enum, - PConFfi {mod = "Basis", datatyp = "bool", arg = NONE, - con = if b then "True" else "False"}, - NONE), - loc) -fun boolTyp loc = (TFfi ("Basis", "int"), loc) - -fun ffiAppExp (module, func, index, loc) = - (EFfiApp (module, func ^ Int.toString index, []), loc) - -fun sequence (befores, center, afters, loc) = - List.foldr (fn (exp, seq) => (ESeq (exp, seq), loc)) - (List.foldl (fn (exp, seq) => (ESeq (seq, exp), loc)) - center - afters) - befores - -fun antiguardUnit (cond, exp, loc) = - (ECase (cond, - [(boolPat (false, loc), exp), - (boolPat (true, loc), (ERecord [], loc))], - {disc = boolTyp loc, result = (TRecord [], loc)}), - loc) - -fun underAbs f (exp as (exp', loc)) = - case exp' of - EAbs (x, y, z, body) => (EAbs (x, y, z, underAbs f body), loc) - | _ => f exp - fun addCacheCheck (index, exp) = let fun f (body as (_, loc)) = @@ -85,7 +85,7 @@ fun addCacheCheck (index, exp) = val check = ffiAppExp ("Cache", "check", index, loc) val store = ffiAppExp ("Cache", "store", index, loc) in - antiguardUnit (check, sequence ([], body, [store], loc), loc) + antiguardUnit (check, sequence ([body, store], loc), loc) end in underAbs f exp @@ -99,9 +99,8 @@ fun addCacheFlush (exp, tablesToIndices) = fun mapFfi func = List.map (fn i => ffiAppExp ("Cache", func, i, loc)) val flushes = IS.listItems (SS.foldr addIndices IS.empty (#written (tablesInExp body))) - in - sequence (mapFfi "flush" flushes, body, mapFfi "ready" flushes, loc) + sequence (mapFfi "flush" flushes @ [body] @ mapFfi "ready" flushes, loc) end in underAbs f exp -- cgit v1.2.3 From a167f651f6a12eab4772ab3cb16b63633e8c77ae Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 20 Sep 2014 13:55:25 -0400 Subject: Default to parsing time strings with the application-configured format --- src/c/urweb.c | 15 +++++++++++---- tests/timeRoundTrip.ur | 3 +++ 2 files changed, 14 insertions(+), 4 deletions(-) create mode 100644 tests/timeRoundTrip.ur diff --git a/src/c/urweb.c b/src/c/urweb.c index d7bc05e3..09514afa 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -2897,13 +2897,17 @@ uw_Basis_time *uw_Basis_stringToTime(uw_context ctx, uw_Basis_string s) { } } else { - if (strptime(s, TIME_FMT_PG, &stm) == end) { + if (strptime(s, ctx->app->time_format, &stm) == end) { uw_Basis_time *r = uw_malloc(ctx, sizeof(uw_Basis_time)); r->seconds = mktime(&stm); r->microseconds = 0; return r; - } - else if (strptime(s, TIME_FMT, &stm) == end) { + } else if (strptime(s, TIME_FMT_PG, &stm) == end) { + uw_Basis_time *r = uw_malloc(ctx, sizeof(uw_Basis_time)); + r->seconds = mktime(&stm); + r->microseconds = 0; + return r; + } else if (strptime(s, TIME_FMT, &stm) == end) { uw_Basis_time *r = uw_malloc(ctx, sizeof(uw_Basis_time)); r->seconds = mktime(&stm); r->microseconds = 0; @@ -3047,7 +3051,10 @@ uw_Basis_time uw_Basis_stringToTime_error(uw_context ctx, uw_Basis_string s) { } } else { - if (strptime(s, TIME_FMT_PG, &stm) == end) { + if (strptime(s, ctx->app->time_format, &stm) == end) { + uw_Basis_time r = { mktime(&stm) }; + return r; + } else if (strptime(s, TIME_FMT_PG, &stm) == end) { uw_Basis_time r = { mktime(&stm) }; return r; } else if (strptime(s, TIME_FMT, &stm) == end) { diff --git a/tests/timeRoundTrip.ur b/tests/timeRoundTrip.ur new file mode 100644 index 00000000..d20e61e8 --- /dev/null +++ b/tests/timeRoundTrip.ur @@ -0,0 +1,3 @@ +fun main () : transaction page = + t <- now; + return {[readError (show t) : time]} -- cgit v1.2.3 From b3f6f1c94a001205dd77ac2e5074e6cc4c300ffd Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 16 Nov 2014 13:39:18 -0500 Subject: uw_remoteSock() --- include/urweb/urweb_cpp.h | 3 +++ src/c/http.c | 2 ++ src/c/urweb.c | 13 +++++++++++++ 3 files changed, 18 insertions(+) diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index d83b2cbb..637cddfc 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -393,4 +393,7 @@ uw_Basis_string uw_Basis_blessData(struct uw_context *, uw_Basis_string); extern const char uw_begin_xhtml[], uw_begin_html5[]; +int uw_remoteSock(struct uw_context *); +void uw_set_remoteSock(struct uw_context *, int sock); + #endif diff --git a/src/c/http.c b/src/c/http.c index 9651a216..e6c7b1af 100644 --- a/src/c/http.c +++ b/src/c/http.c @@ -89,6 +89,8 @@ static void *worker(void *data) { sock = uw_dequeue(); } + uw_set_remoteSock(ctx, sock); + qprintf("Handling connection with thread #%d.\n", me); while (1) { diff --git a/src/c/urweb.c b/src/c/urweb.c index 09514afa..1f2c8b3c 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -476,6 +476,8 @@ struct uw_context { char *output_buffer; size_t output_buffer_size; + + int remoteSock; }; size_t uw_headers_max = SIZE_MAX; @@ -559,6 +561,8 @@ uw_context uw_init(int id, uw_loggers *lg) { ctx->output_buffer = malloc(1); ctx->output_buffer_size = 1; + ctx->remoteSock = -1; + return ctx; } @@ -646,6 +650,7 @@ void uw_reset_keep_error_message(uw_context ctx) { ctx->amInitializing = 0; ctx->usedSig = 0; ctx->needsResig = 0; + ctx->remoteSock = -1; } void uw_reset_keep_request(uw_context ctx) { @@ -4458,3 +4463,11 @@ uw_Basis_string uw_Basis_blessData(uw_context ctx, uw_Basis_string s) { return s; } + +int uw_remoteSock(uw_context ctx) { + return ctx->remoteSock; +} + +void uw_set_remoteSock(uw_context ctx, int sock) { + ctx->remoteSock = sock; +} -- cgit v1.2.3 From ff35b4cbd8c62fed584b48f660e4274c6e357893 Mon Sep 17 00:00:00 2001 From: Sergey Mironov Date: Sun, 12 Oct 2014 10:03:36 +0000 Subject: HTML5 input attributes: placeholder, required, autofocus; email input type (without cformTag equivalent) --- lib/ur/basis.urs | 21 +++++++++++++-------- src/monoize.sml | 1 + 2 files changed, 14 insertions(+), 8 deletions(-) diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 5d0a0c8a..170df50c 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -948,14 +948,19 @@ con formTag = fn (ty :: Type) (inner :: {Unit}) (attrs :: {Type}) => -> [[Form] ~ ctx] => nm :: Name -> unit -> tag attrs ([Form] ++ ctx) inner [] [nm = ty] + +con inputAttrs = [Required = string, Autofocus = string] + + val hidden : formTag string [] [Data = data_attr, Id = string, Value = string] val textbox : formTag string [] ([Value = string, Size = int, Placeholder = string, Source = source string, Onchange = transaction unit, - Ontext = transaction unit] ++ boxAttrs) -val password : formTag string [] ([Value = string, Size = int, Placeholder = string, Onchange = transaction unit] ++ boxAttrs) + Ontext = transaction unit] ++ boxAttrs ++ inputAttrs) +val password : formTag string [] ([Value = string, Size = int, Placeholder = string, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) +val email : formTag string [] ([Value = string, Size = int, Placeholder = string, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) val textarea : formTag string [] ([Rows = int, Cols = int, Onchange = transaction unit, - Ontext = transaction unit] ++ boxAttrs) + Ontext = transaction unit] ++ boxAttrs ++ inputAttrs) -val checkbox : formTag bool [] ([Checked = bool, Onchange = transaction unit] ++ boxAttrs) +val checkbox : formTag bool [] ([Checked = bool, Onchange = transaction unit, Value = string] ++ boxAttrs) type file val fileName : file -> option string @@ -1012,18 +1017,18 @@ con cformTag = fn (attrs :: {Type}) (inner :: {Unit}) => unit -> tag attrs ([Body] ++ ctx) ([Body] ++ inner) [] [] val ctextbox : cformTag ([Value = string, Size = int, Source = source string, Placeholder = string, Onchange = transaction unit, - Ontext = transaction unit] ++ boxAttrs) [] + Ontext = transaction unit] ++ boxAttrs ++ inputAttrs) [] val cpassword : cformTag ([Value = string, Size = int, Source = source string, Placeholder = string, Onchange = transaction unit, - Ontext = transaction unit] ++ boxAttrs) [] + Ontext = transaction unit] ++ boxAttrs ++ inputAttrs) [] val button : cformTag ([Value = string] ++ boxAttrs) [] -val ccheckbox : cformTag ([Value = bool, Size = int, Source = source bool, Onchange = transaction unit] ++ boxAttrs) [] +val ccheckbox : cformTag ([Value = bool, Size = int, Source = source bool, Onchange = transaction unit] ++ boxAttrs ++ inputAttrs) [] val cselect : cformTag ([Source = source string, Onchange = transaction unit] ++ boxAttrs) [Cselect] val coption : unit -> tag [Value = string, Selected = bool] [Cselect, Body] [] [] [] val ctextarea : cformTag ([Value = string, Rows = int, Cols = int, Source = source string, Onchange = transaction unit, - Ontext = transaction unit] ++ boxAttrs) [] + Ontext = transaction unit] ++ boxAttrs ++ inputAttrs) [] (*** Tables *) diff --git a/src/monoize.sml b/src/monoize.sml index 6073a21f..cc5395f0 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3663,6 +3663,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 textbox tag")) | "password" => input "password" + | "email" => input "email" | "textarea" => (case targs of [_, (L.CName name, _)] => -- cgit v1.2.3 From 75d1eedd15edc41b1c2bc9d1fce7a74f37bd78a1 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Tue, 14 Oct 2014 18:05:09 -0400 Subject: Complete overhaul: cache queries based on immediate query result, not eventual HTML output. --- caching-tests/test.db | Bin 3072 -> 5120 bytes caching-tests/test.sql | 7 +- caching-tests/test.ur | 74 +++++++++----- caching-tests/test.urp | 1 + caching-tests/test.urs | 2 + src/cjr_print.sml | 70 +++++++++---- src/compiler.sig | 1 - src/compiler.sml | 6 +- src/monoize.sig | 2 +- src/monoize.sml | 24 +++-- src/multimap_fn.sml | 10 +- src/settings.sig | 3 + src/settings.sml | 4 + src/sources | 2 + src/sql.sig | 2 + src/sql.sml | 20 +++- src/sqlcache.sml | 266 +++++++++++++++++++++++++++++++++++++++++++++---- 17 files changed, 411 insertions(+), 83 deletions(-) diff --git a/caching-tests/test.db b/caching-tests/test.db index a5c91e8f..944aa851 100644 Binary files a/caching-tests/test.db and b/caching-tests/test.db differ diff --git a/caching-tests/test.sql b/caching-tests/test.sql index 862245b7..efa271ec 100644 --- a/caching-tests/test.sql +++ b/caching-tests/test.sql @@ -8,4 +8,9 @@ CREATE TABLE uw_Test_foo01(uw_id integer NOT NULL, uw_bar text NOT NULL, ); - \ No newline at end of file + CREATE TABLE uw_Test_tab(uw_id integer NOT NULL, uw_val integer NOT NULL, + PRIMARY KEY (uw_id) + + ); + + \ No newline at end of file diff --git a/caching-tests/test.ur b/caching-tests/test.ur index a99a387b..cb391da7 100644 --- a/caching-tests/test.ur +++ b/caching-tests/test.ur @@ -1,52 +1,74 @@ table foo01 : {Id : int, Bar : string} PRIMARY KEY Id table foo10 : {Id : int, Bar : string} PRIMARY KEY Id +table tab : {Id : int, Val : int} PRIMARY KEY Id -fun flush01 () : transaction page = - dml (UPDATE foo01 SET Bar = "baz01" WHERE Id = 42); - return - Flushed 1! - - -fun flush10 () : transaction page = - dml (UPDATE foo10 SET Bar = "baz10" WHERE Id = 42); - return - Flushed 2! - - -fun flush11 () : transaction page = - dml (UPDATE foo01 SET Bar = "baz11" WHERE Id = 42); - dml (UPDATE foo10 SET Bar = "baz11" WHERE Id = 42); - return - Flushed 1 and 2! - - -fun cache01 () : transaction page = +fun cache01 () = res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42); return Reading 1. {case res of - None => + None => ? | Some row => {[row.Foo01.Bar]}} -fun cache10 () : transaction page = +fun cache10 () = res <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42); return Reading 2. {case res of - None => + None => ? | Some row => {[row.Foo10.Bar]}} -fun cache11 () : transaction page = +fun cache11 () = res <- oneOrNoRows (SELECT foo01.Bar FROM foo01 WHERE foo01.Id = 42); bla <- oneOrNoRows (SELECT foo10.Bar FROM foo10 WHERE foo10.Id = 42); return Reading 1 and 2. {case res of - None => + None => ? | Some row => {[row.Foo01.Bar]}} {case bla of - None => + None => ? | Some row => {[row.Foo10.Bar]}} + +fun flush01 () = + dml (UPDATE foo01 SET Bar = "baz01" WHERE Id = 42); + return + Flushed 1! + + +fun flush10 () = + dml (UPDATE foo10 SET Bar = "baz10" WHERE Id = 42); + return + Flushed 2! + + +fun flush11 () = + dml (UPDATE foo01 SET Bar = "baz11" WHERE Id = 42); + dml (UPDATE foo10 SET Bar = "baz11" WHERE Id = 42); + return + Flushed 1 and 2! + + +fun cache id = + res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]}); + return + Reading {[id]}. + {case res of + None => ? + | Some row => {[row.Tab.Val]}} + + +fun flush id = + res <- oneOrNoRows (SELECT tab.Val FROM tab WHERE tab.Id = {[id]}); + dml (case res of + None => (INSERT INTO tab (Id, Val) VALUES ({[id]}, 0)) + | Some row => (UPDATE tab SET Val = {[row.Tab.Val + 1]} WHERE Id = {[id]})); + return + (* Flushed {[id]}! *) + {case res of + None => Initialized {[id]}! + | Some row => Incremented {[id]}!} + diff --git a/caching-tests/test.urp b/caching-tests/test.urp index 123f58e5..7ac469f9 100644 --- a/caching-tests/test.urp +++ b/caching-tests/test.urp @@ -3,5 +3,6 @@ sql test.sql safeGet Test/flush01 safeGet Test/flush10 safeGet Test/flush11 +safeGet Test/flush test diff --git a/caching-tests/test.urs b/caching-tests/test.urs index ce7d0350..ace4ba28 100644 --- a/caching-tests/test.urs +++ b/caching-tests/test.urs @@ -4,3 +4,5 @@ val cache11 : unit -> transaction page val flush01 : unit -> transaction page val flush10 : unit -> transaction page val flush11 : unit -> transaction page +val cache : int -> transaction page +val flush : int -> transaction page diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 8ca35234..6427cf3d 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3395,49 +3395,77 @@ fun p_file env (ds, ps) = (* For sqlcache. *) box (List.map - (fn index => + (fn {index, params} => let val i = Int.toString index + fun paramRepeat itemi sep = + let + val rec f = + fn 0 => itemi (Int.toString 0) + | n => f (n-1) ^ itemi (Int.toString n) + in + f (params - 1) + end + val args = paramRepeat (fn p => "uw_Basis_string p" ^ p) ", " + val decls = paramRepeat (fn p => "uw_Basis_string param" ^ i ^ "_" ^ p ^ " = NULL;") "\n" + val sets = paramRepeat (fn p => "param" ^ i ^ "_" ^ p + ^ " = strdup(p" ^ p ^ ");") "\n" + val frees = paramRepeat (fn p => "free(param" ^ i ^ "_" ^ p ^ ");") "\n" + val eqs = paramRepeat (fn p => "strcmp(param" ^ i ^ "_" ^ p + ^ ", p" ^ p ^ ")") " || " in box [string "static char *cache", string i, string " = NULL;", newline, - string "static uw_Basis_bool uw_Cache_check", - string i, - string "(uw_context ctx) { puts(\"SQLCACHE: checked ", + string decls, + newline, + string "static uw_Basis_string uw_Sqlcache_check", string i, - string ".\"); if (cache", + string "(uw_context ctx, ", + string args, + string ") {\n puts(\"SQLCACHE: checked ", string i, - string " == NULL) { uw_recordingStart(ctx); return uw_Basis_False; } else { uw_write(ctx, cache", + string ".\");\n if (cache", string i, - string "); puts(\"SQLCACHE: used ", + (* ASK: is returning the pointer okay? Should we duplicate? *) + string " == NULL || ", + string eqs, + string ") {\n puts(\"miss D:\"); puts(p0);\n return NULL;\n } else {\n puts(\"hit :D\");\n return cache", string i, - string ".\"); return uw_Basis_True; } };", + string ";\n } };", newline, - string "static uw_unit uw_Cache_store", + string "static uw_unit uw_Sqlcache_store", string i, - string "(uw_context ctx) { cache", + string "(uw_context ctx, uw_Basis_string s, ", + string args, + string ") {\n free(cache", string i, - string " = uw_recordingRead(ctx); puts(\"SQLCACHE: stored ", + string ");", + newline, + string frees, + newline, + string "cache", string i, - string ".\"); return uw_unit_v; };", + string " = strdup(s);", + newline, + string sets, newline, - string "static uw_unit uw_Cache_flush", + string "puts(\"SQLCACHE: stored ", string i, - string "(uw_context ctx) { free(cache", + string ".\"); puts(p0);\n return uw_unit_v;\n };", + newline, + string "static uw_unit uw_Sqlcache_flush", string i, - string "); cache", + string "(uw_context ctx) {\n free(cache", string i, - string " = NULL; puts(\"SQLCACHE: flushed ", + string ");\n cache", string i, - string ".\"); return uw_unit_v; };", - newline, - string "static uw_unit uw_Cache_ready", + string " = NULL;\n puts(\"SQLCACHE: flushed ", string i, - string "(uw_context ctx) { return uw_unit_v; };", + string ".\");\n return uw_unit_v;\n };", newline, newline] end) - (!Sqlcache.ffiIndices)), + (Sqlcache.getFfiInfo ())), newline, p_list_sep newline (fn x => x) pds, diff --git a/src/compiler.sig b/src/compiler.sig index fb0245ea..c154240a 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -199,7 +199,6 @@ signature COMPILER = sig val enableBoot : unit -> unit val doIflow : bool ref - val doSqlcache : bool ref val addPath : string * string -> unit val addModuleRoot : string * string -> unit diff --git a/src/compiler.sml b/src/compiler.sml index d7ee8700..fc4067a4 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -83,7 +83,6 @@ type ('src, 'dst) transform = { val debug = ref false val dumpSource = ref false val doIflow = ref false -val doSqlcache = ref false val doDumpSource = ref (fn () => ()) @@ -1457,7 +1456,10 @@ val sigcheck = { val toSigcheck = transform sigcheck "sigcheck" o toSidecheck val sqlcache = { - func = (fn file => (if !doSqlcache then Sqlcache.go file else file)), + func = (fn file => + if Settings.getSqlcache () + then let val file = MonoInline.inlineFull file in Sqlcache.go file end + else file), print = MonoPrint.p_file MonoEnv.empty } diff --git a/src/monoize.sig b/src/monoize.sig index 838d7c4c..951db01b 100644 --- a/src/monoize.sig +++ b/src/monoize.sig @@ -16,7 +16,7 @@ * 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 + * 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 diff --git a/src/monoize.sml b/src/monoize.sml index 6073a21f..d609a67d 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1957,20 +1957,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun (un, state), loc)), loc)), loc) - val body' = (L'.EApp ( + val body'' = (L'.EApp ( (L'.EApp ( (L'.EApp ((L'.ERel 4, loc), (L'.ERel 1, loc)), loc), (L'.ERel 0, loc)), loc), (L'.ERecord [], loc)), loc) - - val body = (L'.EQuery {exps = exps, - tables = tables, - state = state, - query = (L'.ERel 3, loc), - body = body', - initial = (L'.ERel 1, loc)}, - loc) + val body' = (L'.EQuery {exps = exps, + tables = tables, + state = state, + query = (L'.ERel 3, loc), + body = body'', + initial = (L'.ERel 1, loc)}, + loc) + val (body, fm) = if Settings.getSqlcache () then + let + val (urlifiedRel0, fm) = urlifyExp env fm ((L'.ERel 0, loc), state) + in + (Sqlcache.instrumentQuery (body', urlifiedRel0), fm) + end + else (body', fm) in ((L'.EAbs ("q", s, (L'.TFun (ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc)), loc), (L'.EAbs ("f", ft, (L'.TFun (state, (L'.TFun (un, state), loc)), loc), diff --git a/src/multimap_fn.sml b/src/multimap_fn.sml index 585b741f..3dab68a5 100644 --- a/src/multimap_fn.sml +++ b/src/multimap_fn.sml @@ -1,14 +1,16 @@ functor MultimapFn (structure KeyMap : ORD_MAP structure ValSet : ORD_SET) = struct type key = KeyMap.Key.ord_key type item = ValSet.item - type items = ValSet.set + type itemSet = ValSet.set type multimap = ValSet.set KeyMap.map - fun inserts (kToVs : multimap, k : key, vs : items) : multimap = + val empty : multimap = KeyMap.empty + fun insertSet (kToVs : multimap, k : key, vs : itemSet) : multimap = KeyMap.unionWith ValSet.union (kToVs, KeyMap.singleton (k, vs)) fun insert (kToVs : multimap, k : key, v : item) : multimap = - inserts (kToVs, k, ValSet.singleton v) - fun find (kToVs : multimap, k : key) = + insertSet (kToVs, k, ValSet.singleton v) + fun findSet (kToVs : multimap, k : key) = case KeyMap.find (kToVs, k) of SOME vs => vs | NONE => ValSet.empty + val findList : multimap * key -> item list = ValSet.listItems o findSet end diff --git a/src/settings.sig b/src/settings.sig index 9b32e502..e94832e0 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -279,6 +279,9 @@ signature SETTINGS = sig val setLessSafeFfi : bool -> unit val getLessSafeFfi : unit -> bool + val setSqlcache : bool -> unit + val getSqlcache : unit -> bool + val setFilePath : string -> unit (* Sets the directory where we look for files being added below. *) diff --git a/src/settings.sml b/src/settings.sml index eb350c95..81c33c08 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -744,6 +744,10 @@ val less = ref false fun setLessSafeFfi b = less := b fun getLessSafeFfi () = !less +val sqlcache = ref false +fun setSqlcache b = sqlcache := b +fun getSqlcache () = !sqlcache + structure SM = BinaryMapFn(struct type ord_key = string val compare = String.compare diff --git a/src/sources b/src/sources index 8860b310..518b7484 100644 --- a/src/sources +++ b/src/sources @@ -212,6 +212,8 @@ $(SRC)/multimap_fn.sml $(SRC)/sqlcache.sig $(SRC)/sqlcache.sml +$(SRC)/mono_inline.sml + $(SRC)/cjr.sml $(SRC)/postgres.sig diff --git a/src/sql.sig b/src/sql.sig index 2623f5e7..2aba8383 100644 --- a/src/sql.sig +++ b/src/sql.sig @@ -2,6 +2,8 @@ signature SQL = sig val debug : bool ref +val sqlcacheMode : bool ref + type lvar = int datatype func = diff --git a/src/sql.sml b/src/sql.sml index 8d245660..d38de055 100644 --- a/src/sql.sml +++ b/src/sql.sml @@ -270,6 +270,22 @@ fun sqlify chs = | _ => NONE +fun sqlifySqlcache chs = + case chs of + (* Match entire FFI application, not just its argument. *) + Exp (e' as EFfiApp ("Basis", f, [(_, _)]), _) :: chs => + if String.isPrefix "sqlify" f then + SOME ((e', ErrorMsg.dummySpan), chs) + else + NONE + | Exp (ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _), + (EPrim (Prim.String (Prim.Normal, "TRUE")), _)), + ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _), + (EPrim (Prim.String (Prim.Normal, "FALSE")), _))], _), _) :: chs => + SOME (e, chs) + + | _ => NONE + fun constK s = wrap (const s) (fn () => s) val funcName = altL [constK "COUNT", @@ -281,6 +297,8 @@ val funcName = altL [constK "COUNT", val unmodeled = altL [const "COUNT(*)", const "CURRENT_TIMESTAMP"] +val sqlcacheMode = ref false; + fun sqexp chs = log "sqexp" (altL [wrap prim SqConst, @@ -292,7 +310,7 @@ fun sqexp chs = wrap known SqKnown, wrap func SqFunc, wrap unmodeled (fn () => Unmodeled), - wrap sqlify Inj, + wrap (if !sqlcacheMode then sqlifySqlcache else sqlify) Inj, wrap (follow (const "COALESCE(") (follow sqexp (follow (const ",") (follow (keep (fn ch => ch <> #")")) (const ")"))))) (fn ((), (e, _)) => e), diff --git a/src/sqlcache.sml b/src/sqlcache.sml index b01de4c9..563b2162 100644 --- a/src/sqlcache.sml +++ b/src/sqlcache.sml @@ -1,21 +1,247 @@ -structure Sqlcache :> SQLCACHE = struct +structure Sqlcache (* :> SQLCACHE *) = struct open Sql open Mono structure IS = IntBinarySet structure IM = IntBinaryMap -structure StringKey = struct type ord_key = string val compare = String.compare end -structure SS = BinarySetFn (StringKey) -structure SM = BinaryMapFn (StringKey) -structure SIMM = MultimapFn (structure KeyMap = SM structure ValSet = IS) +structure SK = struct type ord_key = string val compare = String.compare end +structure SS = BinarySetFn(SK) +structure SM = BinaryMapFn(SK) +structure SIMM = MultimapFn(structure KeyMap = SM structure ValSet = IS) -val ffiIndices : int list ref = ref [] +(* Filled in by cacheWrap during Sqlcache. *) +val ffiInfo : {index : int, params : int} list ref = ref [] -(* Expression construction utilities. *) +fun getFfiInfo () = !ffiInfo + +(* Program analysis. *) + +val useInjIfPossible = + fn SqConst prim => Inj (EPrim (Prim.String (Prim.Normal, Prim.toString prim)), ErrorMsg.dummySpan) + | sqexp => sqexp + +fun equalities (canonicalTable : string -> string) : + sqexp -> ((string * string) * Mono.exp) list option = + let + val rec eqs = + fn Binop (Exps f, e1, e2) => + (* TODO: use a custom datatype in Exps instead of a function. *) + (case f (Var 1, Var 2) of + Reln (Eq, [Var 1, Var 2]) => + let + val (e1', e2') = (useInjIfPossible e1, useInjIfPossible e2) + in + case (e1', e2') of + (Field (t, f), Inj i) => SOME [((canonicalTable t, f), i)] + | (Inj i, Field (t, f)) => SOME [((canonicalTable t, f), i)] + | _ => NONE + end + | _ => NONE) + | Binop (Props f, e1, e2) => + (* TODO: use a custom datatype in Props instead of a function. *) + (case f (True, False) of + And (True, False) => + (case (eqs e1, eqs e2) of + (SOME eqs1, SOME eqs2) => SOME (eqs1 @ eqs2) + | _ => NONE) + | _ => NONE) + | _ => NONE + in + eqs + end + +val equalitiesQuery = + fn Query1 {From = tablePairs, Where = SOME exp, ...} => + equalities + (* If we have [SELECT ... FROM T AS T' ...], use T, not T'. *) + (fn t => + case List.find (fn (_, tAs) => t = tAs) tablePairs of + NONE => t + | SOME (tOrig, _) => tOrig) + exp + | Query1 {Where = NONE, ...} => SOME [] + | _ => NONE + +val equalitiesDml = + fn Insert (tab, eqs) => SOME (List.mapPartial + (fn (name, sqexp) => + case useInjIfPossible sqexp of + Inj e => SOME ((tab, name), e) + | _ => NONE) + eqs) + | Delete (tab, exp) => equalities (fn _ => tab) exp + (* TODO: examine the updated values and not just the way they're filtered. *) + (* For example, UPDATE foo SET Id = 9001 WHERE Id = 42 should update both the + Id = 42 and Id = 9001 cache entries. Could also think of it as doing a + Delete immediately followed by an Insert. *) + | Update (tab, _, exp) => equalities (fn _ => tab) exp + +val rec tablesQuery = + fn Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs) + | Union (q1, q2) => SS.union (tablesQuery q1, tablesQuery q2) + +val tableDml = + fn Insert (tab, _) => tab + | Delete (tab, _) => tab + | Update (tab, _, _) => tab + + +(* Program instrumentation. *) + +val stringTyp = (TFfi ("Basis", "string"), ErrorMsg.dummySpan) + +val sequence = + fn (exp :: exps) => + let + val loc = ErrorMsg.dummySpan + in + List.foldl (fn (e', seq) => ESeq ((seq, loc), (e', loc))) exp exps + end + | _ => raise Match + +fun ffiAppCache' (func, index, args) : Mono.exp' = + EFfiApp ("Sqlcache", func ^ Int.toString index, args) + +fun ffiAppCache (func, index, args) : Mono. exp = + (ffiAppCache' (func, index, args), ErrorMsg.dummySpan) + +val varPrefix = "queryResult" + +fun indexOfName varName = + if String.isPrefix varPrefix varName + then Int.fromString (String.extract (varName, String.size varPrefix, NONE)) + else NONE + +val incRels = MonoUtil.Exp.map {typ = fn x => x, exp = fn ERel n => ERel (n + 1) | x => x} + +(* Filled in by instrumentQuery during Monoize, used during Sqlcache. *) +val urlifiedRel0s : Mono.exp IM.map ref = ref IM.empty + +(* Used by Monoize. *) +val instrumentQuery = + let + val nextQuery = ref 0 + fun iq (query, urlifiedRel0) = + case query of + (EQuery {state = typ, ...}, loc) => + let + val i = !nextQuery before nextQuery := !nextQuery + 1 + in + urlifiedRel0s := IM.insert (!urlifiedRel0s, i, urlifiedRel0); + (* ASK: name variables properly? *) + (ELet (varPrefix ^ Int.toString i, typ, query, + (* Uses a dummy FFI call to keep the urlified expression around, which + in turn keeps the declarations required for urlification safe from + MonoShake. The dummy call is removed during Sqlcache. *) + (* ASK: is there a better way? *) + (ESeq ((EFfiApp ("Sqlcache", "dummy", [(urlifiedRel0, stringTyp)]), loc), + (ERel 0, loc)), + loc)), + loc) + end + | _ => raise Match + in + iq + end + +val gunk : ((string * string) * Mono.exp) list list ref = ref [[]] + +fun cacheWrap (query, i, urlifiedRel0, eqs) = + case query of + (EQuery {state = typ, ...}, _) => + let + val loc = ErrorMsg.dummySpan + (* TODO: deal with effectful injected expressions. *) + val args = (ffiInfo := {index = i, params = length eqs} :: !ffiInfo; + map (fn (_, e) => (e, stringTyp)) eqs) before gunk := eqs :: !gunk + val argsInc = map (fn (e, t) => (incRels e, t)) args + in + (ECase (ffiAppCache ("check", i, args), + [((PNone stringTyp, loc), + (ELet ("q", typ, query, + (ESeq (ffiAppCache ("store", i, (urlifiedRel0, stringTyp) :: argsInc), + (ERel 0, loc)), + loc)), + loc)), + ((PSome (stringTyp, (PVar ("hit", stringTyp), loc)), loc), + (* ASK: what does this bool do? *) + (EUnurlify ((ERel 0, loc), typ, false), loc))], + {disc = stringTyp, result = typ}), + loc) + end + | _ => raise Match + +fun fileMapfold doExp file start = + case MonoUtil.File.mapfold {typ = Search.return2, + exp = fn x => (fn s => Search.Continue (doExp x s)), + decl = Search.return2} file start of + Search.Continue x => x + | Search.Return _ => raise Match + +fun fileMap doExp file = #1 (fileMapfold (fn x => fn _ => (doExp x, ())) file ()) + +val addChecking = + let + fun doExp queryInfo = + fn e' as ELet (v, t, queryExp as (EQuery {query = queryText, ...}, _), body) => + let + fun bind x f = Option.mapPartial f x + val attempt = + (* Ziv misses Haskell's do notation.... *) + bind (parse query queryText) (fn queryParsed => + (Print.preface ("gunk> ", (MonoPrint.p_exp MonoEnv.empty queryExp)); + bind (indexOfName v) (fn i => + bind (equalitiesQuery queryParsed) (fn eqs => + bind (IM.find (!urlifiedRel0s, i)) (fn urlifiedRel0 => + SOME (ELet (v, t, cacheWrap (queryExp, i, urlifiedRel0, eqs), body), + SS.foldr (fn (tab, qi) => SIMM.insert (qi, tab, i)) + queryInfo + (tablesQuery queryParsed))))))) + in + case attempt of + SOME pair => pair + | NONE => (e', queryInfo) + end + | ESeq ((EFfiApp ("Sqlcache", "dummy", _), _), (e', _)) => (e', queryInfo) + | e' => (e', queryInfo) + in + fn file => fileMapfold (fn exp => fn state => doExp state exp) file SIMM.empty + end + +fun addFlushing (file, queryInfo) = + let + val allIndices : int list = SM.foldr (fn (x, acc) => IS.listItems x @ acc) [] queryInfo + fun flushes indices = map (fn i => ffiAppCache' ("flush", i, [])) indices + val doExp = + fn dmlExp as EDml (dmlText, _) => + let + val indices = + case parse dml dmlText of + SOME dmlParsed => SIMM.findList (queryInfo, tableDml dmlParsed) + | NONE => allIndices + in + sequence (flushes indices @ [dmlExp]) + end + | e' => e' + in + fileMap doExp file + end + +fun go file = + let + val () = Sql.sqlcacheMode := true + in + addFlushing (addChecking file) before Sql.sqlcacheMode := false + end + + +(* BEGIN OLD fun intExp (n, loc) = (EPrim (Prim.Int (Int64.fromInt n)), loc) fun intTyp loc = (TFfi ("Basis", "int"), loc) +fun stringExp (s, loc) = (EPrim (Prim.String (Prim.Normal, s)), loc) + fun boolPat (b, loc) = (PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", arg = NONE, con = if b then "True" else "False"}, @@ -23,11 +249,13 @@ fun boolPat (b, loc) = (PCon (Enum, loc) fun boolTyp loc = (TFfi ("Basis", "int"), loc) -fun ffiAppExp (module, func, index, loc) = - (EFfiApp (module, func ^ Int.toString index, []), loc) +fun ffiAppExp (module, func, index, args, loc) = + (EFfiApp (module, func ^ Int.toString index, args), loc) -fun sequence ((exp :: exps), loc) = +val sequence = + fn ((exp :: exps), loc) => List.foldl (fn (exp, seq) => (ESeq (seq, exp), loc)) exp exps + | _ => raise Match fun antiguardUnit (cond, exp, loc) = (ECase (cond, @@ -41,11 +269,10 @@ fun underAbs f (exp as (exp', loc)) = EAbs (x, y, z, body) => (EAbs (x, y, z, underAbs f body), loc) | _ => f exp -(* Program analysis and augmentation. *) val rec tablesRead = - fn Query1 {From=tablePairs, ...} => SS.fromList (map #1 tablePairs) - | Union (q1,q2) => SS.union (tablesRead q1, tablesRead q2) + fn Query1 {From = tablePairs, ...} => SS.fromList (map #1 tablePairs) + | Union (q1, q2) => SS.union (tablesRead q1, tablesRead q2) val tableWritten = fn Insert (tab, _) => tab @@ -57,7 +284,7 @@ fun tablesInExp' exp' = val nothing = {read = SS.empty, written = SS.empty} in case exp' of - EQuery {query=e, ...} => + EQuery {query = e, ...} => (case parse query e of SOME q => {read = tablesRead q, written = SS.empty} | NONE => nothing) @@ -71,8 +298,11 @@ fun tablesInExp' exp' = val tablesInExp = let fun addTables (exp', {read, written}) = - let val {read = r, written = w} = tablesInExp' exp' - in {read = SS.union (r, read), written = SS.union (w, written)} end + let + val {read = r, written = w} = tablesInExp' exp' + in + {read = SS.union (r, read), written = SS.union (w, written)} + end in MonoUtil.Exp.fold {typ = #2, exp = addTables} {read = SS.empty, written = SS.empty} @@ -150,7 +380,7 @@ fun fileFoldMapiSelected f init (file, indices) = in case MonoUtil.File.mapfold {typ = nada, exp = nada, decl = doDecl} file init of Search.Continue x => x - | _ => (file, init) (* Should never happen. *) + | _ => raise Match (* Should never happen. *) end fun fileMapSelected f = #1 o fileFoldMapiSelected (fn (_, x, _) => (f x, ())) () @@ -178,4 +408,6 @@ fun go file = addCacheFlushing (fileWithChecks, tablesToIndices, writers) end +END OLD *) + end -- cgit v1.2.3 From 0185025d29459fe681afa1c01faa22a5d8034884 Mon Sep 17 00:00:00 2001 From: Ziv Scully Date: Tue, 14 Oct 2014 18:07:09 -0400 Subject: Add mono_inline.sml (which was left out of last commit). --- src/mono_inline.sml | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) create mode 100644 src/mono_inline.sml diff --git a/src/mono_inline.sml b/src/mono_inline.sml new file mode 100644 index 00000000..d23419f3 --- /dev/null +++ b/src/mono_inline.sml @@ -0,0 +1,28 @@ +structure MonoInline = struct + +fun inlineFull file = + let + val oldInline = Settings.getMonoInline () + val oldFull = !MonoReduce.fullMode + in + (Settings.setMonoInline (case Int.maxInt of + NONE => 1000000 + | SOME n => n); + MonoReduce.fullMode := true; + let + val file = MonoReduce.reduce file + val file = MonoOpt.optimize file + val file = Fuse.fuse file + val file = MonoOpt.optimize file + val file = MonoShake.shake file + in + file + end before + (MonoReduce.fullMode := oldFull; + Settings.setMonoInline oldInline)) + handle ex => (Settings.setMonoInline oldInline; + MonoReduce.fullMode := oldFull; + raise ex) + end + +end -- cgit v1.2.3 From 509e9564fe6655fe79e70decf2a61a6a6d3761ba Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 18 Dec 2014 07:48:37 -0500 Subject: Fix XML syntax for closing tags --- src/monoize.sml | 4 +++- tests/nestedInput.ur | 10 ++++++++++ 2 files changed, 13 insertions(+), 1 deletion(-) create mode 100644 tests/nestedInput.ur diff --git a/src/monoize.sml b/src/monoize.sml index 6563da8b..392a05c1 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3447,6 +3447,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = NONE => tagStart | SOME extra => (L'.EStrcat (tagStart, extra), loc) + val firstWord = Substring.string o #1 o Substring.splitl (fn ch => not (Char.isSpace ch)) o Substring.full + fun normal () = let val (xml, fm) = monoExp (env, st, fm) xml @@ -3457,7 +3459,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EStrcat ((L'.EStrcat (tagStart, strH ">"), loc), (L'.EStrcat (xml, - strH (String.concat [""])), loc)), + strH (String.concat [""])), loc)), loc), fm) end diff --git a/tests/nestedInput.ur b/tests/nestedInput.ur new file mode 100644 index 00000000..19a73e15 --- /dev/null +++ b/tests/nestedInput.ur @@ -0,0 +1,10 @@ +fun main () : transaction page = + let + fun handler _ = return + in + return +
    + Uh oh! +
    +     + end -- cgit v1.2.3 From e8f0606212506de059a2ac3730d0a01ecb977c70 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 21 Dec 2014 13:20:11 -0500 Subject: Compatibility fix in header file --- include/urweb/request.h | 1 + 1 file changed, 1 insertion(+) diff --git a/include/urweb/request.h b/include/urweb/request.h index 0b19e7f4..a15df10c 100644 --- a/include/urweb/request.h +++ b/include/urweb/request.h @@ -2,6 +2,7 @@ #define REQUEST_H #include +#include #include "types.h" -- cgit v1.2.3 From 6e9e97242c177c7fbc71678e2b495687ace312f0 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 23 Dec 2014 11:23:27 -0500 Subject: Another try at a proper fix for constraint matching in subsignature checking --- src/elaborate.sml | 63 ++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 41 insertions(+), 22 deletions(-) diff --git a/src/elaborate.sml b/src/elaborate.sml index 749bd2f1..f5edbe3e 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2015,6 +2015,41 @@ fun chaseUnifs c = L'.CUnif (_, _, _, _, ref (L'.Known c)) => chaseUnifs c | _ => c +val consEqSimple = + let + fun ces env (c1 : L'.con, c2 : L'.con) = + let + val c1 = hnormCon env c1 + val c2 = hnormCon env c2 + in + case (#1 c1, #1 c2) of + (L'.CRel n1, L'.CRel n2) => n1 = n2 + | (L'.CNamed n1, L'.CNamed n2) => + n1 = n2 orelse + (case #3 (E.lookupCNamed env n1) of + SOME (L'.CNamed n2', _) => n2' = n1 + | _ => false) + | (L'.CModProj n1, L'.CModProj n2) => n1 = n2 + | (L'.CApp (f1, x1), L'.CApp (f2, x2)) => ces env (f1, f2) andalso ces env (x1, x2) + | (L'.CAbs (x1, k1, c1), L'.CAbs (_, _, c2)) => ces (E.pushCRel env x1 k1) (c1, c2) + | (L'.CName x1, L'.CName x2) => x1 = x2 + | (L'.CRecord (_, xts1), L'.CRecord (_, xts2)) => + ListPair.all (fn ((x1, t1), (x2, t2)) => + ces env (x1, x2) andalso ces env (t2, t2)) (xts1, xts2) + | (L'.CConcat (x1, y1), L'.CConcat (x2, y2)) => + ces env (x1, x2) andalso ces env (y1, y2) + | (L'.CMap _, L'.CMap _) => true + | (L'.CUnit, L'.CUnit) => true + | (L'.CTuple cs1, L'.CTuple cs2) => ListPair.all (ces env) (cs1, cs2) + | (L'.CProj (c1, n1), L'.CProj (c2, n2)) => ces env (c1, c2) andalso n1 = n2 + | (L'.CUnif (_, _, _, _, r1), L'.CUnif (_, _, _, _, r2)) => r1 = r2 + | _ => false + end + in + ces + end + + fun elabExp (env, denv) (eAll as (e, loc)) = let (*val () = eprefaces "elabExp" [("eAll", SourcePrint.p_exp eAll)]*) @@ -3020,26 +3055,7 @@ and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = | (L'.SgnConst sgis1, L'.SgnConst sgis2) => let - (* This reshuffling was added to avoid some unfortunate unification behavior. - * In particular, in sub-signature checking, constraints might be unified, - * even when we don't expect them to be unifiable, deciding on bad values - * for unification variables and dooming later unification. - * By putting all the constraints _last_, we allow all the other unifications - * to happen first, hoping that no unification variables survive to confuse - * constraint unification. *) - - val sgis2 = - let - val (constraints, others) = List.partition - (fn (L'.SgiConstraint _, _) => true - | _ => false) sgis2 - in - case constraints of - [] => sgis2 - | _ => others @ constraints - end - - (*val () = prefaces "subSgn" [("sgn1", p_sgn env sgn1), + (*val () = prefaces "subSgn" [("sgn1", p_sgn env sgn1), ("sgn2", p_sgn env sgn2), ("sgis1", p_sgn env (L'.SgnConst sgis1, loc2)), ("sgis2", p_sgn env (L'.SgnConst sgis2, loc2))]*) @@ -3370,8 +3386,11 @@ and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = seek (fn (env, sgi1All as (sgi1, loc)) => case sgi1 of L'.SgiConstraint (c1, d1) => - if consEq env loc (c1, c2) - andalso consEq env loc (d1, d2) then + (* It's important to do only simple equality checking here, + * with no unification, because constraints are unnamed. + * It's too easy to pick the wrong pair to unify! *) + if consEqSimple env (c1, c2) + andalso consEqSimple env (d1, d2) then SOME env else NONE -- cgit v1.2.3 From 26452ecc4b83760962e180a9949e5020cb360cc2 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 23 Dec 2014 12:24:38 -0500 Subject: New antiquote syntax for ORDER BY --- doc/manual.tex | 2 +- src/urweb.grm | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/doc/manual.tex b/doc/manual.tex index 5935ccbf..eb80e0d5 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -2263,7 +2263,7 @@ $$\begin{array}{rrcll} \textrm{Pre-queries} & q &::=& \mt{SELECT} \; [\mt{DISTINCT}] \; P \; \mt{FROM} \; F,^+ \; [\mt{WHERE} \; E] \; [\mt{GROUP} \; \mt{BY} \; p,^+] \; [\mt{HAVING} \; E] \\ &&& \mid q \; R \; q \mid \{\{\{e\}\}\} \\ \textrm{Relational operators} & R &::=& \mt{UNION} \mid \mt{INTERSECT} \mid \mt{EXCEPT} \\ - \textrm{$\mt{ORDER \; BY}$ items} & O &::=& \mt{RANDOM} [()] \mid \hat{E} \; [o] \mid \hat{E} \; [o], O + \textrm{$\mt{ORDER \; BY}$ items} & O &::=& \mt{RANDOM} [()] \mid \hat{E} \; [o] \mid \hat{E} \; [o], O \mid \{\{\{e\}\}\} \end{array}$$ $$\begin{array}{rrcll} diff --git a/src/urweb.grm b/src/urweb.grm index 995d1329..56e6d2ac 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -2235,6 +2235,7 @@ obopt : (ECApp ((EVar (["Basis"], "sql_order_by_ (CWild (KRecord (KType, dummy), dummy), dummy)), dummy) | ORDER BY obexps (obexps) + | ORDER BY LBRACE LBRACE LBRACE eexp RBRACE RBRACE RBRACE (eexp) obitem : sqlexp diropt (sqlexp, diropt) -- cgit v1.2.3 From 1c58ce1a627bedb4d57e64f429d09721c55de340 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 23 Dec 2014 13:42:20 -0500 Subject: Improve wildify heuristic for finding record type-class witnesses --- src/elaborate.sml | 24 ++++++++++++++---------- 1 file changed, 14 insertions(+), 10 deletions(-) diff --git a/src/elaborate.sml b/src/elaborate.sml index f5edbe3e..84d3dc09 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -3699,19 +3699,23 @@ and wildifyStr env (str, sgn) = fun should t = let val t = normClassConstraint env' t + + fun shouldR c = + case hnormCon env' c of + (L'.CApp (f, _), _) => + (case hnormCon env' f of + (L'.CApp (f, cl), loc) => + (case hnormCon env' f of + (L'.CMap _, _) => isClassOrFolder env' cl + | _ => false) + | _ => false) + | (L'.CConcat (c1, c2), _) => + shouldR c1 orelse shouldR c2 + | c => false in case #1 t of L'.CApp (f, _) => isClassOrFolder env' f - | L'.TRecord t => - (case hnormCon env' t of - (L'.CApp (f, _), _) => - (case hnormCon env' f of - (L'.CApp (f, cl), loc) => - (case hnormCon env' f of - (L'.CMap _, _) => isClassOrFolder env' cl - | _ => false) - | _ => false) - | _ => false) + | L'.TRecord t => shouldR t | _ => false end in -- cgit v1.2.3 From d30a5ee04dd437f969fca7ad2b3faee7ed324562 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 23 Dec 2014 14:41:23 -0500 Subject: List.mem --- lib/ur/list.ur | 10 ++++++++++ lib/ur/list.urs | 2 ++ 2 files changed, 12 insertions(+) diff --git a/lib/ur/list.ur b/lib/ur/list.ur index cbb4faf2..11895884 100644 --- a/lib/ur/list.ur +++ b/lib/ur/list.ur @@ -216,6 +216,16 @@ fun foldlMap [a] [b] [c] f = fold [] end +fun mem [a] (_ : eq a) (x : a) = + let + fun mm ls = + case ls of + [] => False + | y :: ls => y = x || mm ls + in + mm + end + fun find [a] f = let fun find' ls = diff --git a/lib/ur/list.urs b/lib/ur/list.urs index 66007a39..55068935 100644 --- a/lib/ur/list.urs +++ b/lib/ur/list.urs @@ -54,6 +54,8 @@ val filterM : m ::: (Type -> Type) -> monad m -> a ::: Type val foldlMap : a ::: Type -> b ::: Type -> c ::: Type -> (a -> b -> c * b) -> b -> t a -> t c * b +val mem : a ::: Type -> eq a -> a -> t a -> bool + val find : a ::: Type -> (a -> bool) -> t a -> option a val search : a ::: Type -> b ::: Type -> (a -> option b) -> t a -> option b -- cgit v1.2.3 From 80e5288d76eaf9fa4ac264e34fd1299d8e4c0642 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 24 Dec 2014 12:35:20 -0500 Subject: Broaden handling of wildcard rewrites --- src/compiler.sml | 12 +++--------- src/settings.sml | 16 ++++++++++++++++ 2 files changed, 19 insertions(+), 9 deletions(-) diff --git a/src/compiler.sml b/src/compiler.sml index b46643ff..49b251ba 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -693,8 +693,8 @@ fun parseUrp' accLibs fname = | _ => (ErrorMsg.error "Bad path kind spec"; Settings.Any) - fun parseFrom s = - if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then + fun parsePattern s = + if size s > 0 andalso String.sub (s, size s - 1) = #"*" then (Settings.Prefix, String.substring (s, 0, size s - 1)) else (Settings.Exact, s) @@ -709,12 +709,6 @@ fun parseUrp' accLibs fname = | _ => (ErrorMsg.error "Bad filter kind"; url) - fun parsePattern s = - if size s > 0 andalso String.sub (s, size s - 1) = #"*" then - (Settings.Prefix, String.substring (s, 0, size s - 1)) - else - (Settings.Exact, s) - fun read () = case inputCommentableLine inf of EndOfFile => finish [] @@ -801,7 +795,7 @@ fun parseUrp' accLibs fname = fun doit (pkind, from, to, hyph) = let val pkind = parsePkind pkind - val (kind, from) = parseFrom from + val (kind, from) = parsePattern from in rewrites := {pkind = pkind, kind = kind, from = from, to = to, hyphenate = hyph} :: !rewrites end diff --git a/src/settings.sml b/src/settings.sml index eb350c95..fafb38c5 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -378,6 +378,22 @@ type rule = { action : action, kind : pattern_kind, pattern : string } datatype path_kind = Any | Url | Table | Sequence | View | Relation | Cookie | Style type rewrite = { pkind : path_kind, kind : pattern_kind, from : string, to : string, hyphenate : bool } +fun pak2s pak = + case pak of + Exact => "Exact" + | Prefix => "Prefix" +fun pk2s pk = + case pk of + Any => "Any" + | Url => "Url" + | Table => "Table" + | Sequence => "Sequence" + | View => "View" + | Relation => "Relation" + | Cookie => "Cookie" + | Style => "Style" +fun r2s (r : rewrite) = pak2s (#kind r) ^ " " ^ pk2s (#pkind r) ^ ", from<" ^ #from r ^ ">, to<" ^ #to r ^ ">" + val rewrites = ref ([] : rewrite list) fun subsume (pk1, pk2) = -- cgit v1.2.3 From 0562a6b4d4c94d571abfcd407c98ed259a99bd7e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 25 Dec 2014 18:32:27 -0500 Subject: Client-side conversion of string to bool --- lib/js/urweb.js | 2 ++ src/settings.sml | 2 ++ 2 files changed, 4 insertions(+) diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 342dc943..df9097b1 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -1261,6 +1261,8 @@ function eh(x) { function ts(x) { return x.toString() } function bs(b) { return (b ? "True" : "False") } +function s2b(s) { return s == "True" ? true : s == "False" ? false : null; } +function s2be(s) { return s == "True" ? true : s == "False" ? false : er("Illegal Boolean " ^ s); } function id(x) { return x; } function sub(s, i) { return s.charAt(i); } diff --git a/src/settings.sml b/src/settings.sml index fafb38c5..343ea358 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -297,6 +297,8 @@ val jsFuncsBase = basisM [("alert", "alert"), ("mouseEvent", "uw_mouseEvent"), ("keyEvent", "uw_keyEvent"), ("minTime", "0"), + ("stringToBool_error", "s2be"), + ("stringToBool", "s2b"), ("islower", "isLower"), ("isupper", "isUpper"), -- cgit v1.2.3 From c72be04ba3d27e8109a2edbea50a391aaa000dfd Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 26 Dec 2014 12:30:22 -0500 Subject: Add to .hgignore --- .hgignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.hgignore b/.hgignore index 4139717b..c3272f05 100644 --- a/.hgignore +++ b/.hgignore @@ -62,6 +62,7 @@ m4/lt*.m4 config.* configure depcomp +compile install-sh ltmain.sh missing -- cgit v1.2.3 From 24b9ea0474324a135132390d8bf18d36efea2d4e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 30 Dec 2014 17:02:31 -0500 Subject: Fix a bug in subsignature checking for submodules --- src/elaborate.sml | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/elaborate.sml b/src/elaborate.sml index 84d3dc09..ca3bac24 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -3345,7 +3345,12 @@ and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = L'.SgiStr (x', n1, sgn1) => if x = x' then let + (* Don't forget to save & restore the + * counterparts map around recursive calls! + * Otherwise, all sorts of mayhem may result. *) + val saved = !counterparts val () = subSgn' counterparts env loc sgn1 sgn2 + val () = counterparts := saved val env = E.pushStrNamedAs env x n1 sgn1 val env = if n1 = n2 then env -- cgit v1.2.3 From cc8e10b8c398dd73466e9d358e16e14adff2d17f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 3 Jan 2015 09:56:57 -0500 Subject: New release --- CHANGELOG | 8 ++++++++ configure.ac | 4 ++-- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 4ac2df97..e0e91e3d 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,11 @@ +======== +20150103 +======== + +- New antiquote syntax for 'ORDER BY' clauses +- New standard library function: List.mem +- Bug fixes and improvements to type inference + ======== 20141206 ======== diff --git a/configure.ac b/configure.ac index 57a4dc02..fb112a22 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ -AC_INIT([urweb], [20141206]) -WORKING_VERSION=1 +AC_INIT([urweb], [20150103]) +WORKING_VERSION=0 AC_USE_SYSTEM_EXTENSIONS # automake 1.12 requires this, but automake 1.11 doesn't recognize it -- cgit v1.2.3 From 59d197f311ae4d29b9c2c7909ccd8c9c8975c90e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 3 Jan 2015 10:21:26 -0500 Subject: Fixing one small issue with changes to signature matching (grandfathered into release) --- src/elaborate.sml | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/elaborate.sml b/src/elaborate.sml index ca3bac24..f6819830 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2043,6 +2043,10 @@ val consEqSimple = | (L'.CTuple cs1, L'.CTuple cs2) => ListPair.all (ces env) (cs1, cs2) | (L'.CProj (c1, n1), L'.CProj (c2, n2)) => ces env (c1, c2) andalso n1 = n2 | (L'.CUnif (_, _, _, _, r1), L'.CUnif (_, _, _, _, r2)) => r1 = r2 + + | (L'.TFun (d1, r1), L'.TFun (d2, r2)) => ces env (d1, d2) andalso ces env (r1, r2) + | (L'.TRecord c1, L'.TRecord c2) => ces env (c1, c2) + | _ => false end in -- cgit v1.2.3 From f1204c9d8702aa2b394d777c0552f5e9cc0e9fce Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 3 Jan 2015 10:28:36 -0500 Subject: Return to working version mode --- configure.ac | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index fb112a22..28d1bd8e 100644 --- a/configure.ac +++ b/configure.ac @@ -1,5 +1,5 @@ AC_INIT([urweb], [20150103]) -WORKING_VERSION=0 +WORKING_VERSION=1 AC_USE_SYSTEM_EXTENSIONS # automake 1.12 requires this, but automake 1.11 doesn't recognize it -- cgit v1.2.3 From 2127b8bbe36c8864919c03a8f09aee5db6595c72 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 7 Jan 2015 09:25:13 -0500 Subject: Fix arguments to PQprepare() --- src/mysql.sml | 2 +- src/postgres.sml | 6 ++---- src/sqlite.sml | 2 +- 3 files changed, 4 insertions(+), 6 deletions(-) diff --git a/src/mysql.sml b/src/mysql.sml index 29a8c68f..bb654fee 100644 --- a/src/mysql.sml +++ b/src/mysql.sml @@ -446,7 +446,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} = newline, newline, - p_list_sepi newline (fn i => fn (s, n) => + p_list_sepi newline (fn i => fn (s, _) => let fun uhoh this s args = box [p_list_sepi (box []) diff --git a/src/postgres.sml b/src/postgres.sml index b97226c1..6df0331a 100644 --- a/src/postgres.sml +++ b/src/postgres.sml @@ -340,14 +340,12 @@ fun init {dbstring, prepared = ss, tables, views, sequences} = newline, newline, - p_list_sepi newline (fn i => fn (s, n) => + p_list_sepi newline (fn i => fn (s, _) => box [string "res = PQprepare(conn, \"uw", string (Int.toString i), string "\", \"", string (Prim.toCString s), - string "\", ", - string (Int.toString n), - string ", NULL);", + string "\", 0, NULL);", newline, string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", newline, diff --git a/src/sqlite.sml b/src/sqlite.sml index c138415b..a1095709 100644 --- a/src/sqlite.sml +++ b/src/sqlite.sml @@ -202,7 +202,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} = newline, newline, - p_list_sepi newline (fn i => fn (s, n) => + p_list_sepi newline (fn i => fn (s, _) => let fun uhoh this s args = box [p_list_sepi (box []) -- cgit v1.2.3 From 9b8fc824ae3fe7176abf67fecb811dd5bdb89cda Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Mon, 12 Jan 2015 12:02:54 -0500 Subject: Switch to using OpenSSL PRNG for the one remaining rand() --- src/c/urweb.c | 26 +++++++++++++++++--------- 1 file changed, 17 insertions(+), 9 deletions(-) diff --git a/src/c/urweb.c b/src/c/urweb.c index e2881b05..4a00755b 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -167,6 +167,19 @@ void *uw_init_client_data(); void uw_free_client_data(void *); void uw_copy_client_data(void *dst, void *src); +static pthread_mutex_t rand_mutex = PTHREAD_MUTEX_INITIALIZER; + +static uw_Basis_int my_rand() { + pthread_mutex_lock(&rand_mutex); + int r = RAND_bytes((unsigned char *)&ret, sizeof ret); + pthread_mutex_unlock(&rand_mutex); + + if (r) + return abs(r); + else + return -1; +} + static client *new_client() { client *c; @@ -192,7 +205,7 @@ static client *new_client() { pthread_mutex_lock(&c->lock); c->mode = USED; - c->pass = rand(); + c->pass = my_rand(); c->sock = -1; c->last_contact = time(NULL); uw_buffer_reset(&c->msgs); @@ -4221,16 +4234,11 @@ uw_Basis_unit uw_Basis_debug(uw_context ctx, uw_Basis_string s) { return uw_unit_v; } -static pthread_mutex_t rand_mutex = PTHREAD_MUTEX_INITIALIZER; - uw_Basis_int uw_Basis_rand(uw_context ctx) { - uw_Basis_int ret; - pthread_mutex_lock(&rand_mutex); - int r = RAND_bytes((unsigned char *)&ret, sizeof ret); - pthread_mutex_unlock(&rand_mutex); + int r = my_rand(); - if (r) - return abs(ret); + if (r >= 0) + return r; else uw_error(ctx, FATAL, "Random number generation failed"); } -- cgit v1.2.3 From 2207f580efc424d40c81d4dd98fb414e29eaa7f9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 22 Jan 2015 09:46:20 -0500 Subject: Fix silly mistake from last commit; also switch away from rand() in openssl.c --- src/c/openssl.c | 10 ++++++---- src/c/urweb.c | 6 ++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/c/openssl.c b/src/c/openssl.c index 6a998e29..1d820a34 100644 --- a/src/c/openssl.c +++ b/src/c/openssl.c @@ -9,6 +9,7 @@ #include #include +#include #define PASSSIZE 4 @@ -19,10 +20,11 @@ static int password[PASSSIZE]; char *uw_sig_file = NULL; static void random_password() { - int i; - - for (i = 0; i < PASSSIZE; ++i) - password[i] = rand(); + if (!RAND_bytes((unsigned char *)password, sizeof password)) { + fprintf(stderr, "Error generating random password\n"); + perror("RAND_bytes"); + exit(1); + } } void uw_init_crypto() { diff --git a/src/c/urweb.c b/src/c/urweb.c index 4a00755b..7ad58e1d 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -171,11 +171,11 @@ static pthread_mutex_t rand_mutex = PTHREAD_MUTEX_INITIALIZER; static uw_Basis_int my_rand() { pthread_mutex_lock(&rand_mutex); - int r = RAND_bytes((unsigned char *)&ret, sizeof ret); + int ret, r = RAND_bytes((unsigned char *)&ret, sizeof ret); pthread_mutex_unlock(&rand_mutex); if (r) - return abs(r); + return abs(ret); else return -1; } @@ -362,8 +362,6 @@ extern void uw_global_custom(); extern void uw_init_crypto(); void uw_global_init() { - srand(time(NULL) ^ getpid()); - clients = malloc(0); uw_global_custom(); -- cgit v1.2.3 From d64871d978719a36f3f52d6fdaef80fc757fa752 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 22 Jan 2015 09:55:05 -0500 Subject: Fix a potential memory bug in fastcgi.c --- src/c/fastcgi.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/c/fastcgi.c b/src/c/fastcgi.c index f3e66e3a..cda3e1f6 100644 --- a/src/c/fastcgi.c +++ b/src/c/fastcgi.c @@ -333,7 +333,7 @@ static void *worker(void *data) { size_t path_size = 0; char *path_buf = malloc(0); - hs.uppercased = malloc(0); + hs.uppercased = malloc(6); hs.uppercased_len = 0; hs.nvps = malloc(sizeof(nvp)); hs.n_nvps = 1; -- cgit v1.2.3 From df953c3e45f9360ee3523ebf0541bdf962fbe7b9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 22 Jan 2015 11:00:17 -0500 Subject: Reference manual: fix rendering of field removal operators --- doc/manual.tex | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/doc/manual.tex b/doc/manual.tex index eb80e0d5..bcdb7f35 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -6,8 +6,8 @@ \newcommand{\mt}[1]{\mathsf{#1}} \newcommand{\rc}{+ \hspace{-.075in} + \;} -\newcommand{\rcut}{\; \texttt{--} \;} -\newcommand{\rcutM}{\; \texttt{---} \;} +\newcommand{\rcut}{\; \texttt{-{}-} \;} +\newcommand{\rcutM}{\; \texttt{-{}-{}-} \;} \begin{document} -- cgit v1.2.3 From d3e13c67397dd99d4aa30681c05a02cd31d9e386 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 22 Jan 2015 11:26:24 -0500 Subject: Fix case issue in name mangling for MySQL --- src/settings.sml | 45 ++++++++++++++++++++++++++++++++++++++------- 1 file changed, 38 insertions(+), 7 deletions(-) diff --git a/src/settings.sml b/src/settings.sml index 343ea358..19ee0b4a 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -744,15 +744,46 @@ fun capitalize s = "" => "" | _ => str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) +val allLower = CharVector.map Char.toLower + val mangle = ref true fun setMangleSql x = mangle := x -fun mangleSqlTable s = if !mangle then "uw_" ^ capitalize s - else if #name (currentDbms ()) = "mysql" then capitalize s - else lowercase s -fun mangleSql s = if !mangle then "uw_" ^ s - else if #name (currentDbms ()) = "mysql" then lowercase s - else lowercase s -fun mangleSqlCatalog s = if !mangle then "uw_" ^ s else lowercase s + +fun mangleSqlTable s = + if #name (currentDbms ()) = "mysql" then + if !mangle then + "uw_" ^ allLower s + else + allLower s + else + if !mangle then + "uw_" ^ capitalize s + else + lowercase s + +fun mangleSql s = + if #name (currentDbms ()) = "mysql" then + if !mangle then + "uw_" ^ allLower s + else + allLower s + else + if !mangle then + "uw_" ^ s + else + lowercase s + +fun mangleSqlCatalog s = + if #name (currentDbms ()) = "mysql" then + if !mangle then + "uw_" ^ allLower s + else + allLower s + else + if !mangle then + "uw_" ^ s + else + lowercase s val html5 = ref false fun setIsHtml5 b = html5 := b -- cgit v1.2.3 From 2200a9e67a5e280406f55048dc03b5a8fd51d642 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 28 Jan 2015 08:47:04 -0500 Subject: Improve wildification for records of type-class witnesses --- src/elaborate.sml | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/src/elaborate.sml b/src/elaborate.sml index f6819830..5b18ae94 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -3697,6 +3697,21 @@ and wildifyStr env (str, sgn) = | c => ((*Print.preface ("WTF?", p_con env (c, loc));*) NONE) + fun isClassOrFolder' env (c : L'.con) = + case #1 c of + L'.CAbs (x, k, c) => + let + val env = E.pushCRel env x k + + fun toHead (c : L'.con) = + case #1 c of + L'.CApp (c, _) => toHead c + | _ => isClassOrFolder env c + in + toHead (hnormCon env c) + end + | _ => isClassOrFolder env c + fun buildNeeded env sgis = #1 (foldl (fn ((sgi, loc), (nd, env')) => (case sgi of @@ -3715,7 +3730,7 @@ and wildifyStr env (str, sgn) = (case hnormCon env' f of (L'.CApp (f, cl), loc) => (case hnormCon env' f of - (L'.CMap _, _) => isClassOrFolder env' cl + (L'.CMap _, _) => isClassOrFolder' env' cl | _ => false) | _ => false) | (L'.CConcat (c1, c2), _) => -- cgit v1.2.3 From eab0e09b2b4d125abb98e088ff9a03581aa05717 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 1 Feb 2015 12:29:14 -0500 Subject: A new MonoReduce optimization for lifting 'let' out of field projection; JavaScript compilation for exponentiation --- lib/js/urweb.js | 4 ++++ src/jscomp.sml | 2 ++ src/mono_reduce.sml | 17 +++++++++++++---- 3 files changed, 19 insertions(+), 4 deletions(-) diff --git a/lib/js/urweb.js b/lib/js/urweb.js index df9097b1..3bf21dd2 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -112,6 +112,10 @@ function round(n) { return Math.round(n); } +function pow(n, m) { + return Math.pow(n, m); +} + // Time, represented as counts of microseconds since the epoch diff --git a/src/jscomp.sml b/src/jscomp.sml index 1a476739..3709bcd3 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -724,6 +724,8 @@ fun process (file : file) = | "<" => "lt" | "<=" => "le" | "strcmp" => "strcmp" + | "powl" => "pow" + | "powf" => "pow" | _ => raise Fail ("Jscomp: Unknown binary operator " ^ s) val (e1, st) = jsE inner (e1, st) diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 8ca84c15..39d02b99 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -818,10 +818,19 @@ fun reduce (file : file) = search pes end - | EField ((ERecord xes, _), x) => - (case List.find (fn (x', _, _) => x' = x) xes of - SOME (_, e, _) => #1 e - | NONE => e) + | EField (e1, x) => + let + fun yankLets (e : exp) = + case #1 e of + ELet (x, t, e1, e2) => (ELet (x, t, e1, yankLets e2), #2 e) + | ERecord xes => + (case List.find (fn (x', _, _) => x' = x) xes of + SOME (_, e, _) => e + | NONE => (EField (e, x), #2 e)) + | _ => (EField (e, x), #2 e) + in + #1 (yankLets e1) + end | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) => let -- cgit v1.2.3 From 9d277854b9a4fb3ac30bea989c10d7f550e960b4 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 1 Feb 2015 15:50:54 -0500 Subject: Don't allow singleton