summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--demo/listFun.ur24
-rw-r--r--demo/listFun.urs2
-rw-r--r--demo/listShop.ur4
-rw-r--r--demo/listShop.urp1
-rw-r--r--src/cjr_print.sml426
-rw-r--r--src/compiler.sml1
-rw-r--r--src/core_util.sml4
-rw-r--r--src/corify.sml2
-rw-r--r--src/mono_reduce.sml237
-rw-r--r--tests/unurlify.ur7
-rw-r--r--tests/unurlify.urp3
11 files changed, 397 insertions, 314 deletions
diff --git a/demo/listFun.ur b/demo/listFun.ur
index 833aee51..74f249b6 100644
--- a/demo/listFun.ur
+++ b/demo/listFun.ur
@@ -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
diff --git a/demo/listFun.urs b/demo/listFun.urs
index 8fd6eb0d..909bbcf6 100644
--- a/demo/listFun.urs
+++ b/demo/listFun.urs
@@ -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
diff --git a/demo/listShop.ur b/demo/listShop.ur
index 04386349..0c23819f 100644
--- a/demo/listShop.ur
+++ b/demo/listShop.ur
@@ -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)
diff --git a/demo/listShop.urp b/demo/listShop.urp
index 85d318d4..219c6828 100644
--- a/demo/listShop.urp
+++ b/demo/listShop.urp
@@ -1,3 +1,4 @@
+debug
list
listFun
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 3e96b1a6..bfe6414f 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1463,217 +1463,249 @@ fun p_file env (ds, ps) =
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)")
-
- | 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 "] == '/')) ? ({",
+ 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 "uwr_",
+ string x,
+ space,
+ string "=",
+ space,
+ unurlify' rf (#1 t),
+ string ";",
+ newline]) xts),
string "struct",
space,
- string ("__uwd_" ^ ident x ^ "_" ^ Int.toString i),
- space,
- string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_",
- string x,
- string "_",
+ string "__uws_",
string (Int.toString i),
- string "));",
- newline,
- string "tmp->tag",
+ space,
+ string "tmp",
space,
string "=",
space,
- string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n),
- string ";",
- newline,
- string "request",
+ string "{",
space,
- string "+=",
+ p_list_sep (box [string ",", space]) (fn (x, _) => box [string "uwr_",
+ string x]) xts,
space,
- string (Int.toString (size x')),
- string ";",
- newline,
- string "if (request[0] == '/') ++request;",
+ string "};",
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
+
+ | 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
- | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
- space)
+ 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
diff --git a/src/compiler.sml b/src/compiler.sml
index a98f121b..43e361f0 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -535,7 +535,6 @@ fun compile job =
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
diff --git a/src/core_util.sml b/src/core_util.sml
index 76f1b2c0..49182c09 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -785,7 +785,9 @@ fun foldMap {kind, con, exp, decl} s d =
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
diff --git a/src/corify.sml b/src/corify.sml
index 8d754d87..09af27d0 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -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 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
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index e97f3461..f88bea8f 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -275,123 +275,134 @@ fun summarize d (e, _) =
| 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)
-
- | 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)))
-
- | 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
-
- 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
-
- | EField ((ERecord xes, _), x) =>
- (case List.find (fn (x', _, _) => x' = x) xes of
- SOME (_, e, _) => #1 e
- | NONE => e)
-
- | 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)) =>
- 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 =>
- case eff of
- Unsure => false
- | UseRel r =>
- if r = 0 then
- List.all verifyUnused effs
+ 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
+ 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
- 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))
+ 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
+ search pes
+ end
+
+ | EField ((ERecord xes, _), x) =>
+ (case List.find (fn (x', _, _) => x' = x) xes of
+ SOME (_, e, _) => #1 e
+ | NONE => e)
+
+ | 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)) =>
+ 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 =>
+ 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
- e
- end
- else
- #1 (reduceExp env (subExpInExp (0, e') b))
+ #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
diff --git a/tests/unurlify.ur b/tests/unurlify.ur
new file mode 100644
index 00000000..4bb523c1
--- /dev/null
+++ b/tests/unurlify.ur
@@ -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>
diff --git a/tests/unurlify.urp b/tests/unurlify.urp
new file mode 100644
index 00000000..d1e2b8e6
--- /dev/null
+++ b/tests/unurlify.urp
@@ -0,0 +1,3 @@
+debug
+
+unurlify
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-04 15:45:07 +0000