Mercurial > urweb
changeset 398:ab3177746c78
Simple listShop working
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 21 Oct 2008 13:24:54 -0400 |
| parents | 4d519baf357c |
| children | 2d64457eedb1 |
| files | demo/listFun.ur demo/listFun.urs demo/listShop.ur demo/listShop.urp src/cjr_print.sml src/compiler.sml src/core_util.sml src/corify.sml src/mono_reduce.sml tests/unurlify.ur tests/unurlify.urp |
| diffstat | 11 files changed, 389 insertions(+), 306 deletions(-) [+] |
line wrap: on
line diff
--- a/demo/listFun.ur Tue Oct 21 12:06:35 2008 -0400 +++ b/demo/listFun.ur Tue Oct 21 13:24:54 2008 -0400 @@ -1,5 +1,27 @@ +open List + functor Make(M : sig type t + val toString : t -> string + val fromString : string -> option t end) = struct - fun main () = return <xml/> + fun toXml (ls : list M.t) = + case ls of + Nil => <xml>[]</xml> + | Cons (x, ls') => <xml>{[M.toString x]} :: {toXml ls'}</xml> + + fun console (ls : list M.t) = return <xml><body> + Current list: {toXml ls}<br/> + + <form> + Add element: <textbox{#X}/> <submit action={cons ls}/> + </form> + </body></xml> + + and cons (ls : list M.t) (r : {X : string}) = + case M.fromString r.X of + None => return <xml><body>Invalid string!</body></xml> + | Some v => console (Cons (v, ls)) + + fun main () = console Nil end
--- a/demo/listFun.urs Tue Oct 21 12:06:35 2008 -0400 +++ b/demo/listFun.urs Tue Oct 21 13:24:54 2008 -0400 @@ -1,5 +1,7 @@ functor Make(M : sig type t + val toString : t -> string + val fromString : string -> option t end) : sig val main : unit -> transaction page end
--- a/demo/listShop.ur Tue Oct 21 12:06:35 2008 -0400 +++ b/demo/listShop.ur Tue Oct 21 13:24:54 2008 -0400 @@ -1,9 +1,13 @@ structure I = struct type t = int + val toString = show _ + val fromString = read _ end structure S = struct type t = string + val toString = show _ + val fromString = read _ end structure IL = ListFun.Make(I)
--- a/demo/listShop.urp Tue Oct 21 12:06:35 2008 -0400 +++ b/demo/listShop.urp Tue Oct 21 13:24:54 2008 -0400 @@ -1,3 +1,4 @@ +debug list listFun
--- a/src/cjr_print.sml Tue Oct 21 12:06:35 2008 -0400 +++ b/src/cjr_print.sml Tue Oct 21 13:24:54 2008 -0400 @@ -1463,217 +1463,249 @@ str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) fun unurlify (t, loc) = - case t of - TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)") + let + fun unurlify' rf t = + case t of + 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 x, - space, - string "=", - space, - unurlify 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, _) => 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) => - 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" - in - box [string "(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 t - | TFfi ("Basis", "string") => unurlify 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 t, - string ";", - newline, - string "tmp;", - newline, - string "})"], - string ")", - newline, - string ":", - space, - string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x ^ "\"), NULL))))")] - end - - | TDatatype (Default, i, _) => - let - val (x, xncs) = E.lookupDatatype env 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 "] == '/')) ? ({", + | 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 ("__uwd_" ^ ident x ^ "_" ^ Int.toString i), + string "__uws_", + string (Int.toString i), space, - string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_", - string x, - string "_", - string (Int.toString i), - string "));", - newline, - string "tmp->tag", + string "tmp", space, string "=", space, - string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n), - string ";", + string "{", + space, + p_list_sep (box [string ",", space]) (fn (x, _) => box [string "uwr_", + string x]) xts, + space, + 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 t, - string ";", - newline], string "tmp;", newline, - string "})", - space, - string ":", - space, - doEm rest, - string ")"] - in - doEm xncs - end + string "})"] + end - | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function"; - space) + | 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, _) => + let + val (x, xncs) = E.lookupDatatype env 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 + doEm xncs + 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
--- a/src/compiler.sml Tue Oct 21 12:06:35 2008 -0400 +++ b/src/compiler.sml Tue Oct 21 13:24:54 2008 -0400 @@ -535,7 +535,6 @@ else let val dir = OS.FileSys.tmpName () - val () = OS.FileSys.remove dir val cname = OS.Path.joinDirFile {dir = dir, file = "urweb.c"} val oname = OS.Path.joinDirFile {dir = dir, file = "urweb.o"} in
--- a/src/core_util.sml Tue Oct 21 12:06:35 2008 -0400 +++ b/src/core_util.sml Tue Oct 21 13:24:54 2008 -0400 @@ -785,7 +785,9 @@ val maxName = foldl (fn ((d, _) : decl, count) => case d of DCon (_, n, _, _) => Int.max (n, count) - | DDatatype (_, n, _, _) => Int.max (n, count) + | 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
--- a/src/corify.sml Tue Oct 21 12:06:35 2008 -0400 +++ b/src/corify.sml Tue Oct 21 13:24:54 2008 -0400 @@ -696,7 +696,7 @@ | L.DSgn _ => ([], st) | L.DStr (x, n, _, (L.StrFun (xa, na, _, _, str), _)) => - ([], St.bindFunctor st mods x n xa na str) + ([], St.bindFunctor st (x :: mods) x n xa na str) | L.DStr (x, n, _, (L.StrProj (str, x'), _)) => let
--- a/src/mono_reduce.sml Tue Oct 21 12:06:35 2008 -0400 +++ b/src/mono_reduce.sml Tue Oct 21 13:24:54 2008 -0400 @@ -275,123 +275,134 @@ | ENextval e => summarize d e @ [WriteDb] fun exp env 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', _) => #1 e' - | _ => e) + let + (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*) - | EApp ((EAbs (x, t, _, e1), loc), e2) => - ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp env e1), - ("e2", MonoPrint.p_exp env e2)];*) - if impure e2 then - #1 (reduceExp env (ELet (x, t, e2, e1), loc)) - else - #1 (reduceExp env (subExpInExp (0, e2) e1))) + 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) - | ECase (e', pes, {disc, result}) => - 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 + | 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))) - 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 - search pes - end + | ECase (e', pes, {disc, result}) => + 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 - | EField ((ERecord xes, _), x) => - (case List.find (fn (x', _, _) => x' = x) xes of - SOME (_, e, _) => #1 e - | NONE => 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 + search pes + 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)) + | EField ((ERecord xes, _), x) => + (case List.find (fn (x', _, _) => x' = x) xes of + SOME (_, e, _) => #1 e + | NONE => e) - | 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 (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', b) => - if impure e' then - let - val effs_e' = summarize 0 e' - val effs_b = summarize 0 b + | 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)) - fun does eff = List.exists (fn eff' => eff' = eff) effs_e' - val writesPage = does WritePage - val readsDb = does ReadDb - val writesDb = does WriteDb + | ELet (x, t, e', b) => + if impure e' then + let + val effs_e' = summarize 0 e' + val effs_b = summarize 0 b - fun verifyUnused eff = - case eff of - UseRel r => r <> 0 - | Unsure => false - | _ => true + fun does eff = List.exists (fn eff' => eff' = eff) effs_e' + val writesPage = does WritePage + val readsDb = does ReadDb + val writesDb = does WriteDb - 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 + 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 + 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)) - else - e - end - else - #1 (reduceExp env (subExpInExp (0, e') b)) - | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) => - EPrim (Prim.String (s1 ^ s2)) + | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) => + EPrim (Prim.String (s1 ^ s2)) - | _ => e + | _ => e + in + (*Print.prefaces "exp'" [("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*) + r + end and bind (env, b) = case b of
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/unurlify.ur Tue Oct 21 13:24:54 2008 -0400 @@ -0,0 +1,7 @@ +datatype list t = Nil | Cons of t * list t + +fun handler (ls : list bool) = return <xml/> + +fun main () : transaction page = return <xml><body> + <a link={handler Nil}>!</a> +</body></xml>