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