Mercurial > urweb
changeset 910:8e540df3294d
grid1 compiles but gets stuck in JS
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 25 Aug 2009 13:57:56 -0400 |
| parents | 1d3f60e74ec7 |
| children | 12c77dc567a2 |
| files | lib/ur/monad.ur lib/ur/monad.urs lib/ur/top.ur lib/ur/top.urs src/c/urweb.c src/compiler.sml src/core_print.sml src/jscomp.sml src/mono.sml src/mono_opt.sig src/mono_opt.sml src/mono_print.sml src/mono_reduce.sml src/mono_util.sml src/monoize.sml src/reduce.sml src/urweb.grm |
| diffstat | 17 files changed, 315 insertions(+), 118 deletions(-) [+] |
line wrap: on
line diff
--- a/lib/ur/monad.ur Sat Aug 22 16:32:31 2009 -0400 +++ b/lib/ur/monad.ur Tue Aug 25 13:57:56 2009 -0400 @@ -34,6 +34,19 @@ (fn _ _ => return i) [_] fl +fun foldR3 [K] [m] (_ : monad m) [tf1 :: K -> Type] [tf2 :: K -> Type] [tf3 :: K -> Type] [tr :: {K} -> Type] + (f : nm :: Name -> t :: K -> rest :: {K} + -> [[nm] ~ rest] => + tf1 t -> tf2 t -> tf3 t -> tr rest -> m (tr ([nm = t] ++ rest))) + (i : tr []) [r :: {K}] (fl : folder r) = + Top.fold [fn r :: {K} => $(map tf1 r) -> $(map tf2 r) -> $(map tf3 r) -> m (tr r)] + (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] + (acc : _ -> _ -> _ -> m (tr rest)) r1 r2 r3 => + acc' <- acc (r1 -- nm) (r2 -- nm) (r3 -- nm); + f [nm] [t] [rest] ! r1.nm r2.nm r3.nm acc') + (fn _ _ _ => return i) + [_] fl + fun mapR [K] [m] (_ : monad m) [tf :: K -> Type] [tr :: K -> Type] (f : nm :: Name -> t :: K -> tf t -> m (tr t)) = @@foldR [m] _ [tf] [fn r => $(map tr r)]
--- a/lib/ur/monad.urs Sat Aug 22 16:32:31 2009 -0400 +++ b/lib/ur/monad.urs Tue Aug 25 13:57:56 2009 -0400 @@ -22,6 +22,15 @@ -> tr [] -> r :: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) -> m (tr r) +val foldR3 : K --> m ::: (Type -> Type) -> monad m + -> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> tf3 :: (K -> Type) + -> tr :: ({K} -> Type) + -> (nm :: Name -> t :: K -> rest :: {K} + -> [[nm] ~ rest] => + tf1 t -> tf2 t -> tf3 t -> tr rest -> m (tr ([nm = t] ++ rest))) + -> tr [] + -> r :: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) -> $(map tf3 r) -> m (tr r) + val mapR : K --> m ::: (Type -> Type) -> monad m -> tf :: (K -> Type) -> tr :: (K -> Type)
--- a/lib/ur/top.ur Sat Aug 22 16:32:31 2009 -0400 +++ b/lib/ur/top.ur Tue Aug 25 13:57:56 2009 -0400 @@ -155,6 +155,17 @@ f [nm] [t] [rest] ! r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm))) (fn _ _ => i) +fun foldR3 [K] [tf1 :: K -> Type] [tf2 :: K -> Type] [tf3 :: K -> Type] [tr :: {K} -> Type] + (f : nm :: Name -> t :: K -> rest :: {K} + -> [[nm] ~ rest] => + tf1 t -> tf2 t -> tf3 t -> tr rest -> tr ([nm = t] ++ rest)) + (i : tr []) [r :: {K}] (fl : folder r) = + fl [fn r :: {K} => $(map tf1 r) -> $(map tf2 r) -> $(map tf3 r) -> tr r] + (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] + (acc : _ -> _ -> _ -> tr rest) r1 r2 r3 => + f [nm] [t] [rest] ! r1.nm r2.nm r3.nm (acc (r1 -- nm) (r2 -- nm) (r3 -- nm))) + (fn _ _ _ => i) + fun foldRX [K] [tf :: K -> Type] [ctx :: {Unit}] (f : nm :: Name -> t :: K -> rest :: {K} -> [[nm] ~ rest] => @@ -174,6 +185,16 @@ <xml>{f [nm] [t] [rest] ! r1 r2}{acc}</xml>) <xml/> +fun foldRX3 [K] [tf1 :: K -> Type] [tf2 :: K -> Type] [tf3 :: K -> Type] [ctx :: {Unit}] + (f : nm :: Name -> t :: K -> rest :: {K} + -> [[nm] ~ rest] => + tf1 t -> tf2 t -> tf3 t -> xml ctx [] []) = + foldR3 [tf1] [tf2] [tf3] [fn _ => xml ctx [] []] + (fn [nm :: Name] [t :: K] [rest :: {K}] [[nm] ~ rest] + r1 r2 r3 acc => + <xml>{f [nm] [t] [rest] ! r1 r2 r3}{acc}</xml>) + <xml/> + fun queryI [tables ::: {{Type}}] [exps ::: {Type}] [tables ~ exps] (q : sql_query tables exps) (f : $(exps ++ map (fn fields :: {Type} => $fields) tables)
--- a/lib/ur/top.urs Sat Aug 22 16:32:31 2009 -0400 +++ b/lib/ur/top.urs Tue Aug 25 13:57:56 2009 -0400 @@ -84,6 +84,14 @@ -> tr [] -> r :: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) -> tr r +val foldR3 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> tf3 :: (K -> Type) + -> tr :: ({K} -> Type) + -> (nm :: Name -> t :: K -> rest :: {K} + -> [[nm] ~ rest] => + tf1 t -> tf2 t -> tf3 t -> tr rest -> tr ([nm = t] ++ rest)) + -> tr [] + -> r :: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) -> $(map tf3 r) -> tr r + val foldRX : K --> tf :: (K -> Type) -> ctx :: {Unit} -> (nm :: Name -> t :: K -> rest :: {K} -> [[nm] ~ rest] => @@ -97,6 +105,13 @@ -> r :: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) -> xml ctx [] [] +val foldRX3 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> tf3 :: (K -> Type) -> ctx :: {Unit} + -> (nm :: Name -> t :: K -> rest :: {K} + -> [[nm] ~ rest] => + tf1 t -> tf2 t -> tf3 t -> xml ctx [] []) + -> r :: {K} -> folder r + -> $(map tf1 r) -> $(map tf2 r) -> $(map tf3 r) -> xml ctx [] [] + val queryI : tables ::: {{Type}} -> exps ::: {Type} -> [tables ~ exps] => sql_query tables exps
--- a/src/c/urweb.c Sat Aug 22 16:32:31 2009 -0400 +++ b/src/c/urweb.c Tue Aug 25 13:57:56 2009 -0400 @@ -1235,7 +1235,7 @@ } strcpy(s2, "\""); - ctx->heap.front = s2 + 1; + ctx->heap.front = s2 + 2; return r; }
--- a/src/compiler.sml Sat Aug 22 16:32:31 2009 -0400 +++ b/src/compiler.sml Tue Aug 25 13:57:56 2009 -0400 @@ -805,7 +805,7 @@ val toMonoize = transform monoize "monoize" o toEffectize val mono_opt = { - func = (fn x => (MonoOpt.removeServerCalls := false; MonoOpt.optimize x)), + func = MonoOpt.optimize, print = MonoPrint.p_file MonoEnv.empty } @@ -841,12 +841,7 @@ val toJscomp = transform jscomp "jscomp" o toMono_opt2 -val mono_opt' = { - func = (fn x => (MonoOpt.removeServerCalls := true; MonoOpt.optimize x)), - print = MonoPrint.p_file MonoEnv.empty -} - -val toMono_opt3 = transform mono_opt' "mono_opt3" o toJscomp +val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp val fuse = { func = Fuse.fuse,
--- a/src/core_print.sml Sat Aug 22 16:32:31 2009 -0400 +++ b/src/core_print.sml Tue Aug 25 13:57:56 2009 -0400 @@ -427,6 +427,7 @@ string x, space, string ":", + space, p_con env t, space, string "=",
--- a/src/jscomp.sml Sat Aug 22 16:32:31 2009 -0400 +++ b/src/jscomp.sml Tue Aug 25 13:57:56 2009 -0400 @@ -86,7 +86,7 @@ | ESignalReturn e => varDepth e | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2) | ESignalSource e => varDepth e - | EServerCall (e, ek, _, _, _) => Int.max (varDepth e, varDepth ek) + | EServerCall (e, ek, _, _) => Int.max (varDepth e, varDepth ek) | ERecv (e, ek, _) => Int.max (varDepth e, varDepth ek) | ESleep (e, ek) => Int.max (varDepth e, varDepth ek) @@ -130,7 +130,7 @@ | ESignalReturn e => cu inner e | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2 | ESignalSource e => cu inner e - | EServerCall (e, ek, _, _, _) => cu inner e andalso cu inner ek + | EServerCall (e, ek, _, _) => cu inner e andalso cu inner ek | ERecv (e, ek, _) => cu inner e andalso cu inner ek | ESleep (e, ek) => cu inner e andalso cu inner ek in @@ -389,6 +389,7 @@ fun unurlifyExp loc (t : typ, st) = case #1 t of TRecord [] => ("null", st) + | TFfi ("Basis", "unit") => ("null", st) | TRecord [(x, t)] => let val (e, st) = unurlifyExp loc (t, st) @@ -524,6 +525,7 @@ fun unsupported s = (EM.errorAt loc (s ^ " in code to be compiled to JavaScript[2]"); + Print.preface ("Code", MonoPrint.p_exp MonoEnv.empty e); (str "ERROR", st)) val strcat = strcat loc @@ -669,7 +671,24 @@ raise Fail "Jscomp: deStrcat") val quoteExp = quoteExp loc + + val hasQuery = U.Exp.exists {typ = fn _ => false, + exp = fn EQuery _ => true + | _ => false} + + val indirectQuery = U.Exp.exists {typ = fn _ => false, + exp = fn ENamed n => + (case IM.find (nameds, n) of + NONE => false + | SOME e => hasQuery e) + | _ => false} + in + (*if indirectQuery e then + Print.preface ("Indirect", MonoPrint.p_exp MonoEnv.empty e) + else + ();*) + (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e), ("inner", Print.PD.string (Int.toString inner))];*) @@ -1041,7 +1060,7 @@ st) end - | EServerCall (e, ek, t, eff, _) => + | EServerCall (e, ek, t, eff) => let val (e, st) = jsE inner (e, st) val (ek, st) = jsE inner (ek, st) @@ -1320,13 +1339,12 @@ ((ESignalSource e, loc), st) end - | EServerCall (e1, e2, t, ef, ue) => + | EServerCall (e1, e2, t, ef) => let val (e1, st) = exp outer (e1, st) val (e2, st) = exp outer (e2, st) - val (ue, st) = exp outer (ue, st) in - ((EServerCall (e1, e2, t, ef, ue), loc), st) + ((EServerCall (e1, e2, t, ef), loc), st) end | ERecv (e1, e2, t) => let
--- a/src/mono.sml Sat Aug 22 16:32:31 2009 -0400 +++ b/src/mono.sml Tue Aug 25 13:57:56 2009 -0400 @@ -114,7 +114,7 @@ | ESignalBind of exp * exp | ESignalSource of exp - | EServerCall of exp * exp * typ * effect * exp + | EServerCall of exp * exp * typ * effect | ERecv of exp * exp * typ | ESleep of exp * exp
--- a/src/mono_opt.sig Sat Aug 22 16:32:31 2009 -0400 +++ b/src/mono_opt.sig Tue Aug 25 13:57:56 2009 -0400 @@ -29,7 +29,5 @@ val optimize : Mono.file -> Mono.file val optExp : Mono.exp -> Mono.exp - - val removeServerCalls : bool ref - + end
--- a/src/mono_opt.sml Sat Aug 22 16:32:31 2009 -0400 +++ b/src/mono_opt.sml Tue Aug 25 13:57:56 2009 -0400 @@ -30,8 +30,6 @@ open Mono structure U = MonoUtil -val removeServerCalls = ref false - fun typ t = t fun decl d = d @@ -482,12 +480,6 @@ | [] => raise Fail "MonoOpt impossible nil") | NONE => e end - - | EServerCall (_, _, _, _, ue) => - if !removeServerCalls then - optExp ue - else - e | _ => e
--- a/src/mono_print.sml Sat Aug 22 16:32:31 2009 -0400 +++ b/src/mono_print.sml Tue Aug 25 13:57:56 2009 -0400 @@ -335,11 +335,11 @@ p_exp env e, string ")"] - | EServerCall (n, e, _, _, _) => box [string "Server(", - p_exp env n, - string ")[", - p_exp env e, - string "]"] + | EServerCall (n, e, _, _) => box [string "Server(", + p_exp env n, + string ")[", + p_exp env e, + string "]"] | ERecv (n, e, _) => box [string "Recv(", p_exp env n, string ")[",
--- a/src/mono_reduce.sml Sat Aug 22 16:32:31 2009 -0400 +++ b/src/mono_reduce.sml Tue Aug 25 13:57:56 2009 -0400 @@ -354,7 +354,7 @@ | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 | ESignalSource e => summarize d e - | EServerCall (e, ek, _, _, _) => summarize d e @ summarize d ek @ [Unsure] + | EServerCall (e, ek, _, _) => summarize d e @ summarize d ek @ [Unsure] | ERecv (e, ek, _) => summarize d e @ summarize d ek @ [Unsure] | ESleep (e, ek) => summarize d e @ summarize d ek @ [Unsure] in
--- a/src/mono_util.sml Sat Aug 22 16:32:31 2009 -0400 +++ b/src/mono_util.sml Tue Aug 25 13:57:56 2009 -0400 @@ -362,16 +362,14 @@ fn e' => (ESignalSource e', loc)) - | EServerCall (s, ek, t, eff, ue) => + | EServerCall (s, ek, t, eff) => S.bind2 (mfe ctx s, fn s' => S.bind2 (mfe ctx ek, fn ek' => - S.bind2 (mft t, + S.map2 (mft t, fn t' => - S.map2 (mfe ctx ue, - fn ue' => - (EServerCall (s', ek', t', eff, ue'), loc))))) + (EServerCall (s', ek', t', eff), loc)))) | ERecv (s, ek, t) => S.bind2 (mfe ctx s, fn s' =>
--- a/src/monoize.sml Sat Aug 22 16:32:31 2009 -0400 +++ b/src/monoize.sml Tue Aug 25 13:57:56 2009 -0400 @@ -3162,10 +3162,6 @@ val (ek, fm) = monoExp (env, st, fm) ek - val unRpced = foldl (fn (e1, e2) => (L'.EApp (e2, e1), loc)) (L'.ENamed n, loc) es - val unRpced = (L'.EApp (unRpced, (L'.ERecord [], loc)), loc) - val unRpced = (L'.EApp (ek, unRpced), loc) - val unRpced = (L'.EApp (unRpced, (L'.ERecord [], loc)), loc) val unit = (L'.TRecord [], loc) val ekf = (L'.EAbs ("f", @@ -3186,7 +3182,7 @@ else L'.ReadOnly - val e = (L'.EServerCall (call, ek, t, eff, unRpced), loc) + val e = (L'.EServerCall (call, ek, t, eff), loc) val e = liftExpInExp 0 e val e = (L'.EAbs ("_", unit, unit, e), loc) in
--- a/src/reduce.sml Sat Aug 22 16:32:31 2009 -0400 +++ b/src/reduce.sml Tue Aug 25 13:57:56 2009 -0400 @@ -254,12 +254,12 @@ let (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all), ("env", Print.PD.string (e2s env))]*) - (*val () = if dangling (edepth env) all then + val () = if dangling (edepth env) all then (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all), ("env", Print.PD.string (e2s env))]; raise Fail "!") else - ()*) + () val r = case e of EPrim _ => all @@ -299,17 +299,6 @@ | EFfi _ => all | EFfiApp (m, f, es) => (EFfiApp (m, f, map (exp env) es), loc) - | EApp ( - (EApp - ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _), - _), _), - (EApp ( - (EApp ( - (ECApp ( - (ECApp ((EFfi ("Basis", "return"), _), _), _), - _), _), - _), _), v), _)), _), trans2) => exp env (EApp (trans2, v), loc) - (*| EApp ( (EApp ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _), @@ -341,73 +330,216 @@ loc) end*) - | EApp ( - (EApp - ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), _), t2), _), - (EFfi ("Basis", "transaction_monad"), _)), _), - (EServerCall (n, es, ke, dom, ran), _)), _), - trans2) => - let - val e' = (EFfi ("Basis", "bind"), loc) - val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) - val e' = (ECApp (e', dom), loc) - val e' = (ECApp (e', t2), loc) - val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) - val e' = (EApp (e', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc) - val e' = (EApp (e', E.liftExpInExp 0 trans2), loc) - val e' = (EAbs ("x", dom, t2, e'), loc) - val e' = (EServerCall (n, es, e', dom, t2), loc) - in - exp env e' - end - - | EApp ( - (EApp - ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), mt), _), _), _), t3), _), - me), _), - (EApp ((EApp - ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _), - _), _), - trans1), _), trans2), _)), _), - trans3) => - let - val e'' = (EFfi ("Basis", "bind"), loc) - val e'' = (ECApp (e'', mt), loc) - val e'' = (ECApp (e'', t2), loc) - val e'' = (ECApp (e'', t3), loc) - val e'' = (EApp (e'', me), loc) - val e'' = (EApp (e'', (EApp (E.liftExpInExp 0 trans2, (ERel 0, loc)), loc)), loc) - val e'' = (EApp (e'', E.liftExpInExp 0 trans3), loc) - val e'' = (EAbs ("xb", t1, (CApp (mt, t3), loc), e''), loc) - - val e' = (EFfi ("Basis", "bind"), loc) - val e' = (ECApp (e', mt), loc) - val e' = (ECApp (e', t1), loc) - val e' = (ECApp (e', t3), loc) - val e' = (EApp (e', me), loc) - val e' = (EApp (e', trans1), loc) - val e' = (EApp (e', e''), loc) - (*val () = print "Before\n"*) - val ee' = exp env e' - (*val () = print "After\n"*) - in - (*Print.prefaces "Commute" [("Pre", CorePrint.p_exp CoreEnv.empty (e, loc)), - ("Mid", CorePrint.p_exp CoreEnv.empty e'), - ("env", Print.PD.string (e2s env)), - ("Post", CorePrint.p_exp CoreEnv.empty ee')];*) - ee' - end - | EApp (e1, e2) => let + val env' = deKnown env + + fun reassoc e = + case #1 e of + EApp + ((EApp + ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), + t1), + _), t2), _), + (EFfi ("Basis", "transaction_monad"), _)), _), + (EServerCall (n, es, (EAbs (_, _, _, ke), _), dom, ran), _)), _), + trans3) => + let + val e' = (EFfi ("Basis", "bind"), loc) + val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) + val e' = (ECApp (e', dom), loc) + val e' = (ECApp (e', t2), loc) + val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) + val e' = (EApp (e', ke), loc) + val e' = (EApp (e', E.liftExpInExp 0 trans3), loc) + val e' = reassoc e' + val e' = (EAbs ("x", dom, t2, e'), loc) + val e' = (EServerCall (n, es, e', dom, t2), loc) + in + e' + end + + | EApp + ((EApp + ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), + t1), + _), t2), _), + (EFfi ("Basis", "transaction_monad"), _)), _), + (EServerCall (n, es, ke, dom, ran), _)), _), + trans3) => + let + val e' = (EFfi ("Basis", "bind"), loc) + val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) + val e' = (ECApp (e', dom), loc) + val e' = (ECApp (e', t2), loc) + val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) + val e' = (EApp (e', exp (UnknownE :: env') + (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), + loc) + val e' = (EApp (e', E.liftExpInExp 0 trans3), loc) + val e' = reassoc e' + val e' = (EAbs ("x", dom, t2, e'), loc) + val e' = (EServerCall (n, es, e', dom, t2), loc) + in + e' + end + + | EApp + ((EApp + ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), mt), + _), _), _), t3), _), + me), _), + (EApp ((EApp + ((EApp ((ECApp ((ECApp ((ECApp ( + (EFfi ("Basis", "bind"), _), _), _), + t1), _), t2), _), + _), _), + trans1), _), (EAbs (_, _, _, trans2), _)), _)), _), + trans3) => + let + val e'' = (EFfi ("Basis", "bind"), loc) + val e'' = (ECApp (e'', mt), loc) + val e'' = (ECApp (e'', t2), loc) + val e'' = (ECApp (e'', t3), loc) + val e'' = (EApp (e'', me), loc) + val e'' = (EApp (e'', trans2), loc) + val e'' = (EApp (e'', E.liftExpInExp 0 trans3), loc) + val e'' = reassoc e'' + val e'' = (EAbs ("xb", t1, (CApp (mt, t3), loc), e''), loc) + + val e' = (EFfi ("Basis", "bind"), loc) + val e' = (ECApp (e', mt), loc) + val e' = (ECApp (e', t1), loc) + val e' = (ECApp (e', t3), loc) + val e' = (EApp (e', me), loc) + val e' = (EApp (e', trans1), loc) + val e' = (EApp (e', e''), loc) + in + e' + end + + | EApp + ((EApp + ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), mt), + _), _), _), t3), _), + me), _), + (EApp ((EApp + ((EApp ((ECApp ((ECApp ((ECApp ( + (EFfi ("Basis", "bind"), _), _), _), + t1), _), t2), _), + _), _), + trans1), _), trans2), _)), _), + trans3) => + let + val e'' = (EFfi ("Basis", "bind"), loc) + val e'' = (ECApp (e'', mt), loc) + val e'' = (ECApp (e'', t2), loc) + val e'' = (ECApp (e'', t3), loc) + val e'' = (EApp (e'', me), loc) + val () = print "In2\n" + val e'' = (EApp (e'', exp (UnknownE :: env') + (EApp (E.liftExpInExp 0 trans2, (ERel 0, loc)), + loc)), + loc) + val () = print "Out2\n" + val e'' = (EApp (e'', E.liftExpInExp 0 trans3), loc) + val e'' = reassoc e'' + val e'' = (EAbs ("xb", t1, (CApp (mt, t3), loc), e''), loc) + + val e' = (EFfi ("Basis", "bind"), loc) + val e' = (ECApp (e', mt), loc) + val e' = (ECApp (e', t1), loc) + val e' = (ECApp (e', t3), loc) + val e' = (EApp (e', me), loc) + val e' = (EApp (e', trans1), loc) + val e' = (EApp (e', e''), loc) + in + e' + end + + | _ => e + val e1 = exp env e1 val e2 = exp env e2 + val e12 = reassoc (EApp (e1, e2), loc) in - case #1 e1 of - EAbs (_, _, _, b) => + case #1 e12 of + EApp ((EAbs (_, _, _, b), _), e2) => ((*Print.preface ("Body", CorePrint.p_exp CoreEnv.empty b);*) - exp (KnownE e2 :: deKnown env) b) - | _ => (EApp (e1, e2), loc) + exp (KnownE e2 :: env') b) + (*| EApp + ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), + _), t2), _), + _), _), + (EApp ( + (EApp ( + (ECApp ( + (ECApp ((EFfi ("Basis", "return"), _), _), _), + _), _), + _), _), v), _)) => + (ELet ("rv", con env t1, v, + exp (deKnown env) (EApp (E.liftExpInExp 0 e2, (ERel 0, loc)), loc)), loc)*) + (*| EApp + ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), _), _), t1), + _), t2), _), + (EFfi ("Basis", "transaction_monad"), _)), _), + (EServerCall (n, es, ke, dom, ran), _)) => + let + val e' = (EFfi ("Basis", "bind"), loc) + val e' = (ECApp (e', (CFfi ("Basis", "transaction"), loc)), loc) + val e' = (ECApp (e', dom), loc) + val e' = (ECApp (e', t2), loc) + val e' = (EApp (e', (EFfi ("Basis", "transaction_monad"), loc)), loc) + val e' = (EApp (e', (EApp (E.liftExpInExp 0 ke, (ERel 0, loc)), loc)), loc) + val e' = (EApp (e', E.liftExpInExp 0 (exp env e2)), loc) + val e' = (EAbs ("x", dom, t2, e'), loc) + val e' = (EServerCall (n, es, e', dom, t2), loc) + val e' = exp (deKnown env) e' + in + (*Print.prefaces "SC" [("Old", CorePrint.p_exp CoreEnv.empty all), + ("New", CorePrint.p_exp CoreEnv.empty e')]*) + e' + end + | EApp + ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), loc), mt), + _), _), _), t3), _), + me), _), + (EApp ((EApp + ((EApp ((ECApp ((ECApp ((ECApp ((EFfi ("Basis", "bind"), _), _), _), + t1), _), t2), _), + _), _), + trans1), _), trans2), _)) => + let + val e'' = (EFfi ("Basis", "bind"), loc) + val e'' = (ECApp (e'', mt), loc) + val e'' = (ECApp (e'', t2), loc) + val e'' = (ECApp (e'', t3), loc) + val e'' = (EApp (e'', me), loc) + val e'' = (EApp (e'', (EApp (E.liftExpInExp 0 trans2, (ERel 0, loc)), loc)), loc) + val e'' = (EApp (e'', E.liftExpInExp 0 e2), loc) + val e'' = (EAbs ("xb", t1, (CApp (mt, t3), loc), e''), loc) + + val e' = (EFfi ("Basis", "bind"), loc) + val e' = (ECApp (e', mt), loc) + val e' = (ECApp (e', t1), loc) + val e' = (ECApp (e', t3), loc) + val e' = (EApp (e', me), loc) + val e' = (EApp (e', trans1), loc) + val e' = (EApp (e', e''), loc) + (*val () = Print.prefaces "Going in" [("e", CorePrint.p_exp CoreEnv.empty (e, loc)), + ("e1", CorePrint.p_exp CoreEnv.empty e1), + ("e'", CorePrint.p_exp CoreEnv.empty e')]*) + val ee' = exp (deKnown env) e' + val () = Print.prefaces "Coming out" [("ee'", CorePrint.p_exp CoreEnv.empty ee')] + in + (*Print.prefaces "Commute" [("Pre", CorePrint.p_exp CoreEnv.empty (e, loc)), + ("Mid", CorePrint.p_exp CoreEnv.empty e'), + ("env", Print.PD.string (e2s env)), + ("Post", CorePrint.p_exp CoreEnv.empty ee')];*) + ee' + end + | _ => (EApp (e1, exp env e2), loc)*) + | _ => e12 end | EAbs (x, dom, ran, e) => (EAbs (x, con env dom, con env ran, exp (UnknownE :: env) e), loc) @@ -568,7 +700,8 @@ | 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) | EServerCall (n, es, e, t1, t2) => (EServerCall (n, map (exp env) es, exp env e, con env t1, con env t2), loc) @@ -618,7 +751,8 @@ (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', pe, pc, ce, cc) => ((DTable (s, n, con namedC [] c, s',
--- a/src/urweb.grm Sat Aug 22 16:32:31 2009 -0400 +++ b/src/urweb.grm Tue Aug 25 13:57:56 2009 -0400 @@ -1087,6 +1087,13 @@ (EField (e, ident), loc)) (EVar (#1 path, #2 path, Infer), s (pathleft, pathright)) idents end) + | LPAREN eexp RPAREN DOT idents (let + val loc = s (LPARENleft, identsright) + in + foldl (fn (ident, e) => + (EField (e, ident), loc)) + eexp idents + end) | AT path DOT idents (let val loc = s (ATleft, identsright) in