Mercurial > urweb

comparison src/monoize.sml @ 709:0406e9cccb72

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
FOREIGN KEY, without ability to link NULL to NOT NULL (and with some lingering problems in row inference)
author Adam Chlipala <adamc@hcoop.net>
date Tue, 07 Apr 2009 18:47:47 -0400
parents d8217b4cb617
children 915ec60592d4
comparison
equal deleted inserted replaced
708:1a317a707d71 709:0406e9cccb72
152 | L.CApp ((L.CApp ((L.CFfi ("Basis", "primary_key"), _), _), _), _) => 152 | L.CApp ((L.CApp ((L.CFfi ("Basis", "primary_key"), _), _), _), _) =>
153 (L'.TFfi ("Basis", "string"), loc) 153 (L'.TFfi ("Basis", "string"), loc)
154 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraints"), _), _), _), _) => 154 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraints"), _), _), _), _) =>
155 (L'.TFfi ("Basis", "sql_constraints"), loc) 155 (L'.TFfi ("Basis", "sql_constraints"), loc)
156 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraint"), _), _), _), _) => 156 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraint"), _), _), _), _) =>
157 (L'.TFfi ("Basis", "string"), loc)
158 | L.CApp ((L.CApp ((L.CFfi ("Basis", "matching"), _), _), _), _) =>
159 let
160 val string = (L'.TFfi ("Basis", "string"), loc)
161 in
162 (L'.TRecord [("1", string), ("2", string)], loc)
163 end
164 | L.CApp ((L.CFfi ("Basis", "propagation_mode"), _), _) =>
157 (L'.TFfi ("Basis", "string"), loc) 165 (L'.TFfi ("Basis", "string"), loc)
158 166
159 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_subset"), _), _), _), _) => 167 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_subset"), _), _), _), _) =>
160 (L'.TRecord [], loc) 168 (L'.TRecord [], loc)
161 | L.CFfi ("Basis", "sql_relop") => 169 | L.CFfi ("Basis", "sql_relop") =>
1213 val unique = (nm, t) :: unique 1221 val unique = (nm, t) :: unique
1214 in 1222 in
1215 ((L'.EPrim (Prim.String ("UNIQUE (" 1223 ((L'.EPrim (Prim.String ("UNIQUE ("
1216 ^ String.concatWith ", " (map (fn (x, _) => "uw_" ^ monoName env x) unique) 1224 ^ String.concatWith ", " (map (fn (x, _) => "uw_" ^ monoName env x) unique)
1217 ^ ")")), loc), 1225 ^ ")")), loc),
1226 fm)
1227 end
1228
1229 | L.EFfi ("Basis", "mat_nil") =>
1230 let
1231 val string = (L'.TFfi ("Basis", "string"), loc)
1232 val stringE = (L'.EPrim (Prim.String ""), loc)
1233 in
1234 ((L'.ERecord [("1", stringE, string),
1235 ("2", stringE, string)], loc), fm)
1236 end
1237 | L.ECApp (
1238 (L.ECApp (
1239 (L.ECApp (
1240 (L.ECApp (
1241 (L.ECApp (
1242 (L.EFfi ("Basis", "mat_cons"), _),
1243 _), _),
1244 _), _),
1245 _), _),
1246 (L.CName nm1, _)), _),
1247 (L.CName nm2, _)) =>
1248 let
1249 val string = (L'.TFfi ("Basis", "string"), loc)
1250 val mat = (L'.TRecord [("1", string), ("2", string)], loc)
1251 in
1252 ((L'.EAbs ("m", mat, mat,
1253 (L'.ECase ((L'.EField ((L'.ERel 0, loc), "1"), loc),
1254 [((L'.PPrim (Prim.String ""), loc),
1255 (L'.ERecord [("1", (L'.EPrim (Prim.String ("uw_" ^ nm1)), loc), string),
1256 ("2", (L'.EPrim (Prim.String ("uw_" ^ nm2)), loc), string)], loc)),
1257 ((L'.PWild, loc),
1258 (L'.ERecord [("1", (L'.EStrcat (
1259 (L'.EPrim (Prim.String ("uw_" ^ nm1 ^ ", ")), loc),
1260 (L'.EField ((L'.ERel 0, loc), "1"), loc)), loc), string),
1261 ("2", (L'.EStrcat (
1262 (L'.EPrim (Prim.String ("uw_" ^ nm2 ^ ", ")), loc),
1263 (L'.EField ((L'.ERel 0, loc), "2"), loc)), loc), string)],
1264 loc))],
1265 {disc = string,
1266 result = mat}), loc)), loc),
1267 fm)
1268 end
1269
1270 | L.ECApp ((L.EFfi ("Basis", "restrict"), _), _) => ((L'.EPrim (Prim.String "RESTRICT"), loc), fm)
1271 | L.ECApp ((L.EFfi ("Basis", "cascade"), _), _) => ((L'.EPrim (Prim.String "CASCADE"), loc), fm)
1272 | L.ECApp ((L.EFfi ("Basis", "no_action"), _), _) => ((L'.EPrim (Prim.String "NO ACTION"), loc), fm)
1273 | L.ECApp ((L.EFfi ("Basis", "set_null"), _), _) => ((L'.EPrim (Prim.String "SET NULL"), loc), fm)
1274
1275 | L.ECApp (
1276 (L.ECApp (
1277 (L.ECApp (
1278 (L.ECApp (
1279 (L.ECApp (
1280 (L.ECApp (
1281 (L.ECApp (
1282 (L.ECApp (
1283 (L.EFfi ("Basis", "foreign_key"), _),
1284 _), _),
1285 _), _),
1286 _), _),
1287 _), _),
1288 _), _),
1289 _), _),
1290 _), _),
1291 _) =>
1292 let
1293 val unit = (L'.TRecord [], loc)
1294 val string = (L'.TFfi ("Basis", "string"), loc)
1295 val mat = (L'.TRecord [("1", string), ("2", string)], loc)
1296 val recd = (L'.TRecord [("OnDelete", string),
1297 ("OnUpdate", string)], loc)
1298
1299 fun strcat [] = raise Fail "Monoize.strcat"
1300 | strcat [e] = e
1301 | strcat (e1 :: es) = (L'.EStrcat (e1, strcat es), loc)
1302
1303 fun prop (fd, kw) =
1304 (L'.ECase ((L'.EField ((L'.ERel 0, loc), fd), loc),
1305 [((L'.PPrim (Prim.String "NO ACTION"), loc),
1306 (L'.EPrim (Prim.String ""), loc)),
1307 ((L'.PWild, loc),
1308 strcat [(L'.EPrim (Prim.String (" ON " ^ kw ^ " ")), loc),
1309 (L'.EField ((L'.ERel 0, loc), fd), loc)])],
1310 {disc = string,
1311 result = string}), loc)
1312 in
1313 ((L'.EAbs ("m", mat, (L'.TFun (string, (L'.TFun (recd, string), loc)), loc),
1314 (L'.EAbs ("tab", string, (L'.TFun (recd, string), loc),
1315 (L'.EAbs ("pr", recd, string,
1316 strcat [(L'.EPrim (Prim.String "FOREIGN KEY ("), loc),
1317 (L'.EField ((L'.ERel 2, loc), "1"), loc),
1318 (L'.EPrim (Prim.String ") REFERENCES "), loc),
1319 (L'.ERel 1, loc),
1320 (L'.EPrim (Prim.String " ("), loc),
1321 (L'.EField ((L'.ERel 2, loc), "2"), loc),
1322 (L'.EPrim (Prim.String ")"), loc),
1323 prop ("OnDelete", "DELETE"),
1324 prop ("OnUpdate", "UPDATE")]), loc)), loc)), loc),
1218 fm) 1325 fm)
1219 end 1326 end
1220 1327
1221 | L.EFfiApp ("Basis", "dml", [e]) => 1328 | L.EFfiApp ("Basis", "dml", [e]) =>
1222 let 1329 let