summaryrefslogtreecommitdiff
path: root/src/cjr_print.sml
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-08-09 16:13:27 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-08-09 16:13:27 -0400
commit9f1c85cf0ef4be94bf189dea486806298f09ab51 (patch)
tree007835aa119d7ec7cae1d7de078850147ab9ca13 /src/cjr_print.sml
parentc79947821b62c16f0a5a21fb5ec935c1dba00aae (diff)
Library improvements; proper list [un]urlification; remove server-side ServerCalls; eta reduction in type inference
Diffstat (limited to 'src/cjr_print.sml')
-rw-r--r--src/cjr_print.sml89
1 files changed, 79 insertions, 10 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 83b49719..0fd6339d 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -962,9 +962,11 @@ fun unurlify env (t, loc) =
unurlify' IS.empty t
end
+val urlify1 = ref 0
+
fun urlify env t =
let
- fun urlify' rf level (t as (_, loc)) =
+ fun urlify' rf rfl level (t as (_, loc)) =
case #1 t of
TFfi ("Basis", "unit") => box []
| TFfi (m, t) => box [string ("uw_" ^ ident m ^ "_urlify" ^ capitalize t
@@ -1007,7 +1009,7 @@ fun urlify env t =
newline]
else
[]),
- urlify' rf (level + 1) t,
+ urlify' rf rfl (level + 1) t,
string "}",
newline] :: blocks,
true)
@@ -1079,8 +1081,9 @@ fun urlify env t =
string "it0) {",
newline,
box [string "if (it0) {",
+ newline,
if isUnboxable t then
- urlify' rf 0 t
+ urlify' rf rfl 0 t
else
box [p_typ env t,
space,
@@ -1094,11 +1097,12 @@ fun urlify env t =
string has_arg,
string "/\");",
newline,
- urlify' rf 1 t,
+ urlify' rf rfl 1 t,
string ";",
newline],
string "} else {",
- box [string "uw_write(ctx, \"",
+ box [newline,
+ string "uw_write(ctx, \"",
string no_arg,
string "\");",
newline],
@@ -1165,7 +1169,7 @@ fun urlify env t =
string x',
string ";",
newline,
- urlify' rf 1 t,
+ urlify' rf rfl 1 t,
newline],
string "} else {",
newline,
@@ -1208,7 +1212,7 @@ fun urlify env t =
if isUnboxable t then
box [string "uw_write(ctx, \"Some/\");",
newline,
- urlify' rf level t]
+ urlify' rf rfl level t]
else
box [p_typ env t,
space,
@@ -1223,19 +1227,84 @@ fun urlify env t =
newline,
string "uw_write(ctx, \"Some/\");",
newline,
- urlify' rf (level + 1) t,
+ urlify' rf rfl (level + 1) t,
string ";",
newline],
string "} else {",
- box [string "uw_write(ctx, \"None\");",
+ box [newline,
+ string "uw_write(ctx, \"None\");",
newline],
string "}",
newline]
+ | TList (t, i) =>
+ if IS.member (rfl, i) then
+ box [string "urlifyl_",
+ string (Int.toString i),
+ string "(it",
+ string (Int.toString level),
+ string ");",
+ newline]
+ else
+ let
+ val rfl = IS.add (rfl, i)
+ in
+ box [string "({",
+ space,
+ string "void",
+ space,
+ string "urlifyl_",
+ string (Int.toString i),
+ string "(struct __uws_",
+ string (Int.toString i),
+ space,
+ string "*it0) {",
+ newline,
+ box [string "if (it0) {",
+ newline,
+ p_typ env t,
+ space,
+ string "it1",
+ space,
+ string "=",
+ space,
+ string "it0->__uwf_1;",
+ newline,
+ string "uw_write(ctx, \"Cons/\");",
+ newline,
+ urlify' rf rfl 1 t,
+ string ";",
+ newline,
+ string "uw_write(ctx, \"/\");",
+ newline,
+ string "urlifyl_",
+ string (Int.toString i),
+ string "(it0->__uwf_2);",
+ newline,
+ string "} else {",
+ newline,
+ box [string "uw_write(ctx, \"Nil\");",
+ newline],
+ string "}",
+ newline],
+ string "}",
+ newline,
+ newline,
+
+ string "urlifyl_",
+ string (Int.toString i),
+ string "(it",
+ string (Int.toString level),
+ string ");",
+ newline,
+ string "});",
+ newline]
+ end
+
| _ => (ErrorMsg.errorAt loc "Unable to choose a URL encoding function";
space)
in
- urlify' IS.empty 0 t
+ urlify' IS.empty IS.empty 0 t
end
fun sql_type_in env (tAll as (t, loc)) =