Mercurial > urweb

comparison src/cjr_print.sml @ 905:7a4b026e45dd

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Library improvements; proper list [un]urlification; remove server-side ServerCalls; eta reduction in type inference
author Adam Chlipala <adamc@hcoop.net>
date Sun, 09 Aug 2009 16:13:27 -0400
parents 2faf558b2d05
children d6a71f19a3d8
comparison
equal deleted inserted replaced
904:6d9538ce94d8 905:7a4b026e45dd
960 space) 960 space)
961 in 961 in
962 unurlify' IS.empty t 962 unurlify' IS.empty t
963 end 963 end
964 964
965 val urlify1 = ref 0
966
965 fun urlify env t = 967 fun urlify env t =
966 let 968 let
967 fun urlify' rf level (t as (_, loc)) = 969 fun urlify' rf rfl level (t as (_, loc)) =
968 case #1 t of 970 case #1 t of
969 TFfi ("Basis", "unit") => box [] 971 TFfi ("Basis", "unit") => box []
970 | TFfi (m, t) => box [string ("uw_" ^ ident m ^ "_urlify" ^ capitalize t 972 | TFfi (m, t) => box [string ("uw_" ^ ident m ^ "_urlify" ^ capitalize t
971 ^ "_w(ctx, it" ^ Int.toString level ^ ");"), 973 ^ "_w(ctx, it" ^ Int.toString level ^ ");"),
972 newline] 974 newline]
1005 box (if printingSinceLastSlash then 1007 box (if printingSinceLastSlash then
1006 [string "uw_write(ctx, \"/\");", 1008 [string "uw_write(ctx, \"/\");",
1007 newline] 1009 newline]
1008 else 1010 else
1009 []), 1011 []),
1010 urlify' rf (level + 1) t, 1012 urlify' rf rfl (level + 1) t,
1011 string "}", 1013 string "}",
1012 newline] :: blocks, 1014 newline] :: blocks,
1013 true) 1015 true)
1014 end) 1016 end)
1015 ([], false) xts 1017 ([], false) xts
1077 else 1079 else
1078 string "*", 1080 string "*",
1079 string "it0) {", 1081 string "it0) {",
1080 newline, 1082 newline,
1081 box [string "if (it0) {", 1083 box [string "if (it0) {",
1084 newline,
1082 if isUnboxable t then 1085 if isUnboxable t then
1083 urlify' rf 0 t 1086 urlify' rf rfl 0 t
1084 else 1087 else
1085 box [p_typ env t, 1088 box [p_typ env t,
1086 space, 1089 space,
1087 string "it1", 1090 string "it1",
1088 space, 1091 space,
1092 newline, 1095 newline,
1093 string "uw_write(ctx, \"", 1096 string "uw_write(ctx, \"",
1094 string has_arg, 1097 string has_arg,
1095 string "/\");", 1098 string "/\");",
1096 newline, 1099 newline,
1097 urlify' rf 1 t, 1100 urlify' rf rfl 1 t,
1098 string ";", 1101 string ";",
1099 newline], 1102 newline],
1100 string "} else {", 1103 string "} else {",
1101 box [string "uw_write(ctx, \"", 1104 box [newline,
1105 string "uw_write(ctx, \"",
1102 string no_arg, 1106 string no_arg,
1103 string "\");", 1107 string "\");",
1104 newline], 1108 newline],
1105 string "}", 1109 string "}",
1106 newline], 1110 newline],
1163 space, 1167 space,
1164 string "it0->data.uw_", 1168 string "it0->data.uw_",
1165 string x', 1169 string x',
1166 string ";", 1170 string ";",
1167 newline, 1171 newline,
1168 urlify' rf 1 t, 1172 urlify' rf rfl 1 t,
1169 newline], 1173 newline],
1170 string "} else {", 1174 string "} else {",
1171 newline, 1175 newline,
1172 box [doEm rest, 1176 box [doEm rest,
1173 newline], 1177 newline],
1206 string (Int.toString level), 1210 string (Int.toString level),
1207 string ") {", 1211 string ") {",
1208 if isUnboxable t then 1212 if isUnboxable t then
1209 box [string "uw_write(ctx, \"Some/\");", 1213 box [string "uw_write(ctx, \"Some/\");",
1210 newline, 1214 newline,
1211 urlify' rf level t] 1215 urlify' rf rfl level t]
1212 else 1216 else
1213 box [p_typ env t, 1217 box [p_typ env t,
1214 space, 1218 space,
1215 string "it", 1219 string "it",
1216 string (Int.toString (level + 1)), 1220 string (Int.toString (level + 1)),
1221 string (Int.toString level), 1225 string (Int.toString level),
1222 string ";", 1226 string ";",
1223 newline, 1227 newline,
1224 string "uw_write(ctx, \"Some/\");", 1228 string "uw_write(ctx, \"Some/\");",
1225 newline, 1229 newline,
1226 urlify' rf (level + 1) t, 1230 urlify' rf rfl (level + 1) t,
1227 string ";", 1231 string ";",
1228 newline], 1232 newline],
1229 string "} else {", 1233 string "} else {",
1230 box [string "uw_write(ctx, \"None\");", 1234 box [newline,
1235 string "uw_write(ctx, \"None\");",
1231 newline], 1236 newline],
1232 string "}", 1237 string "}",
1233 newline] 1238 newline]
1234 1239
1240 | TList (t, i) =>
1241 if IS.member (rfl, i) then
1242 box [string "urlifyl_",
1243 string (Int.toString i),
1244 string "(it",
1245 string (Int.toString level),
1246 string ");",
1247 newline]
1248 else
1249 let
1250 val rfl = IS.add (rfl, i)
1251 in
1252 box [string "({",
1253 space,
1254 string "void",
1255 space,
1256 string "urlifyl_",
1257 string (Int.toString i),
1258 string "(struct __uws_",
1259 string (Int.toString i),
1260 space,
1261 string "*it0) {",
1262 newline,
1263 box [string "if (it0) {",
1264 newline,
1265 p_typ env t,
1266 space,
1267 string "it1",
1268 space,
1269 string "=",
1270 space,
1271 string "it0->__uwf_1;",
1272 newline,
1273 string "uw_write(ctx, \"Cons/\");",
1274 newline,
1275 urlify' rf rfl 1 t,
1276 string ";",
1277 newline,
1278 string "uw_write(ctx, \"/\");",
1279 newline,
1280 string "urlifyl_",
1281 string (Int.toString i),
1282 string "(it0->__uwf_2);",
1283 newline,
1284 string "} else {",
1285 newline,
1286 box [string "uw_write(ctx, \"Nil\");",
1287 newline],
1288 string "}",
1289 newline],
1290 string "}",
1291 newline,
1292 newline,
1293
1294 string "urlifyl_",
1295 string (Int.toString i),
1296 string "(it",
1297 string (Int.toString level),
1298 string ");",
1299 newline,
1300 string "});",
1301 newline]
1302 end
1303
1235 | _ => (ErrorMsg.errorAt loc "Unable to choose a URL encoding function"; 1304 | _ => (ErrorMsg.errorAt loc "Unable to choose a URL encoding function";
1236 space) 1305 space)
1237 in 1306 in
1238 urlify' IS.empty 0 t 1307 urlify' IS.empty IS.empty 0 t
1239 end 1308 end
1240 1309
1241 fun sql_type_in env (tAll as (t, loc)) = 1310 fun sql_type_in env (tAll as (t, loc)) =
1242 case t of 1311 case t of
1243 TFfi ("Basis", "int") => Int 1312 TFfi ("Basis", "int") => Int