Mercurial > urweb

comparison src/monoize.sml @ 705:e6706a1df013

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Track uniqueness sets in table types
author Adam Chlipala <adamc@hcoop.net>
date Tue, 07 Apr 2009 14:11:32 -0400
parents 70cbdcf5989b
children d8217b4cb617
comparison
equal deleted inserted replaced
704:70cbdcf5989b 705:e6706a1df013
137 (L'.TSource, loc) 137 (L'.TSource, loc)
138 | L.CApp ((L.CFfi ("Basis", "signal"), _), t) => 138 | L.CApp ((L.CFfi ("Basis", "signal"), _), t) =>
139 (L'.TSignal (mt env dtmap t), loc) 139 (L'.TSignal (mt env dtmap t), loc)
140 | L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) => 140 | L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) =>
141 (L'.TFfi ("Basis", "string"), loc) 141 (L'.TFfi ("Basis", "string"), loc)
142 | L.CApp ((L.CFfi ("Basis", "sql_table"), _), _) => 142 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_table"), _), _), _), _) =>
143 (L'.TFfi ("Basis", "string"), loc) 143 (L'.TFfi ("Basis", "string"), loc)
144 | L.CFfi ("Basis", "sql_sequence") => 144 | L.CFfi ("Basis", "sql_sequence") =>
145 (L'.TFfi ("Basis", "string"), loc) 145 (L'.TFfi ("Basis", "string"), loc)
146 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query"), _), _), _), _) => 146 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_query"), _), _), _), _) =>
147 (L'.TFfi ("Basis", "string"), loc) 147 (L'.TFfi ("Basis", "string"), loc)
149 (L'.TFfi ("Basis", "string"), loc) 149 (L'.TFfi ("Basis", "string"), loc)
150 | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _) => 150 | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_exp"), _), _), _), _), _), _), _), _) =>
151 (L'.TFfi ("Basis", "string"), loc) 151 (L'.TFfi ("Basis", "string"), loc)
152 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraints"), _), _), _), _) => 152 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraints"), _), _), _), _) =>
153 (L'.TFfi ("Basis", "sql_constraints"), loc) 153 (L'.TFfi ("Basis", "sql_constraints"), loc)
154 | L.CApp ((L.CFfi ("Basis", "sql_constraint"), _), _) => 154 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_constraint"), _), _), _), _) =>
155 (L'.TFfi ("Basis", "string"), loc) 155 (L'.TFfi ("Basis", "string"), loc)
156 156
157 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_subset"), _), _), _), _) => 157 | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_subset"), _), _), _), _) =>
158 (L'.TRecord [], loc) 158 (L'.TRecord [], loc)
159 | L.CFfi ("Basis", "sql_relop") => 159 | L.CFfi ("Basis", "sql_relop") =>
1160 end 1160 end
1161 1161
1162 | L.ECApp ((L.EFfi ("Basis", "no_constraint"), _), _) => 1162 | L.ECApp ((L.EFfi ("Basis", "no_constraint"), _), _) =>
1163 ((L'.ERecord [], loc), 1163 ((L'.ERecord [], loc),
1164 fm) 1164 fm)
1165 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "one_constraint"), _), _), _), (L.CName name, _)) => 1165 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "one_constraint"), _), _), _), _), _), (L.CName name, _)) =>
1166 ((L'.EAbs ("c", 1166 ((L'.EAbs ("c",
1167 (L'.TFfi ("Basis", "string"), loc), 1167 (L'.TFfi ("Basis", "string"), loc),
1168 (L'.TFfi ("Basis", "sql_constraints"), loc), 1168 (L'.TFfi ("Basis", "sql_constraints"), loc),
1169 (L'.ERecord [(name, (L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))], loc)), loc), 1169 (L'.ERecord [(name, (L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))], loc)), loc),
1170 fm) 1170 fm)
1171 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "join_constraints"), _), _), _), _), _), _) => 1171 | L.ECApp (
1172 (L.ECApp (
1173 (L.ECApp (
1174 (L.EFfi ("Basis", "join_constraints"), _),
1175 _), _),
1176 _), _),
1177 _) =>
1172 let 1178 let
1173 val constraints = (L'.TFfi ("Basis", "sql_constraints"), loc) 1179 val constraints = (L'.TFfi ("Basis", "sql_constraints"), loc)
1174 in 1180 in
1175 ((L'.EAbs ("cs1", constraints, (L'.TFun (constraints, constraints), loc), 1181 ((L'.EAbs ("cs1", constraints, (L'.TFun (constraints, constraints), loc),
1176 (L'.EAbs ("cs2", constraints, constraints, 1182 (L'.EAbs ("cs2", constraints, constraints,
1177 (L'.EStrcat ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), 1183 (L'.EStrcat ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
1178 fm) 1184 fm)
1179 end 1185 end
1180 1186
1181 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "unique"), _), _), _), 1187 | L.ECApp (
1182 (L.CRecord (_, unique), _)) => 1188 (L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "unique"), _), _), _), t), _),
1183 ((L'.EPrim (Prim.String ("UNIQUE (" 1189 nm), _),
1184 ^ String.concatWith ", " (map (fn (x, _) => "uw_" ^ monoName env x) unique) 1190 (L.CRecord (_, unique), _)) =>
1185 ^ ")")), loc), 1191 let
1186 fm) 1192 val unique = (nm, t) :: unique
1193 in
1194 ((L'.EPrim (Prim.String ("UNIQUE ("
1195 ^ String.concatWith ", " (map (fn (x, _) => "uw_" ^ monoName env x) unique)
1196 ^ ")")), loc),
1197 fm)
1198 end
1187 1199
1188 | L.EFfiApp ("Basis", "dml", [e]) => 1200 | L.EFfiApp ("Basis", "dml", [e]) =>
1189 let 1201 let
1190 val (e, fm) = monoExp (env, st, fm) e 1202 val (e, fm) = monoExp (env, st, fm) e
1191 in 1203 in
1192 ((L'.EDml e, loc), 1204 ((L'.EDml e, loc),
1193 fm) 1205 fm)
1194 end 1206 end
1195 1207
1196 | L.ECApp ((L.EFfi ("Basis", "insert"), _), fields) => 1208 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "insert"), _), fields), _), _) =>
1197 (case monoType env (L.TRecord fields, loc) of 1209 (case monoType env (L.TRecord fields, loc) of
1198 (L'.TRecord fields, _) => 1210 (L'.TRecord fields, _) =>
1199 let 1211 let
1200 val s = (L'.TFfi ("Basis", "string"), loc) 1212 val s = (L'.TFfi ("Basis", "string"), loc)
1201 val fields = map (fn (x, _) => (x, s)) fields 1213 val fields = map (fn (x, _) => (x, s)) fields
1215 sc ")"]), loc)), loc), 1227 sc ")"]), loc)), loc),
1216 fm) 1228 fm)
1217 end 1229 end
1218 | _ => poly ()) 1230 | _ => poly ())
1219 1231
1220 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "update"), _), _), _), changed) => 1232 | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "update"), _), _), _), _), _), changed) =>
1221 (case monoType env (L.TRecord changed, loc) of 1233 (case monoType env (L.TRecord changed, loc) of
1222 (L'.TRecord changed, _) => 1234 (L'.TRecord changed, _) =>
1223 let 1235 let
1224 val s = (L'.TFfi ("Basis", "string"), loc) 1236 val s = (L'.TFfi ("Basis", "string"), loc)
1225 val changed = map (fn (x, _) => (x, s)) changed 1237 val changed = map (fn (x, _) => (x, s)) changed
1244 (L'.ERel 0, loc)]), loc)), loc)), loc), 1256 (L'.ERel 0, loc)]), loc)), loc)), loc),
1245 fm) 1257 fm)
1246 end 1258 end
1247 | _ => poly ()) 1259 | _ => poly ())
1248 1260
1249 | L.ECApp ((L.EFfi ("Basis", "delete"), _), _) => 1261 | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "delete"), _), _), _), _) =>
1250 let 1262 let
1251 val s = (L'.TFfi ("Basis", "string"), loc) 1263 val s = (L'.TFfi ("Basis", "string"), loc)
1252 fun sc s = (L'.EPrim (Prim.String s), loc) 1264 fun sc s = (L'.EPrim (Prim.String s), loc)
1253 in 1265 in
1254 ((L'.EAbs ("tab", s, (L'.TFun (s, s), loc), 1266 ((L'.EAbs ("tab", s, (L'.TFun (s, s), loc),
1345 let 1357 let
1346 fun sc s = (L'.EPrim (Prim.String s), loc) 1358 fun sc s = (L'.EPrim (Prim.String s), loc)
1347 val s = (L'.TFfi ("Basis", "string"), loc) 1359 val s = (L'.TFfi ("Basis", "string"), loc)
1348 val un = (L'.TRecord [], loc) 1360 val un = (L'.TRecord [], loc)
1349 fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc) 1361 fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc)
1362
1363 val tables = List.mapPartial
1364 (fn (x, (L.CTuple [y, _], _)) => SOME (x, y)
1365 | _ => (E.errorAt loc "Bad sql_query1 tables pair";
1366 NONE))
1367 tables
1350 1368
1351 fun doTables tables = 1369 fun doTables tables =
1352 let 1370 let
1353 val tables = map (fn ((L.CName x, _), xts) => 1371 val tables = map (fn ((L.CName x, _), xts) =>
1354 (case monoType env (L.TRecord xts, loc) of 1372 (case monoType env (L.TRecord xts, loc) of
2479 val ts = map (monoType env) ts 2497 val ts = map (monoType env) ts
2480 val ran = monoType env ran 2498 val ran = monoType env ran
2481 in 2499 in
2482 SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)]) 2500 SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)])
2483 end 2501 end
2484 | L.DTable (x, n, (L.CRecord (_, xts), _), s, e) => 2502 | L.DTable (x, n, (L.CRecord (_, xts), _), s, e, _) =>
2485 let 2503 let
2486 val t = (L.CFfi ("Basis", "string"), loc) 2504 val t = (L.CFfi ("Basis", "string"), loc)
2487 val t' = (L'.TFfi ("Basis", "string"), loc) 2505 val t' = (L'.TFfi ("Basis", "string"), loc)
2488 val s = "uw_" ^ s 2506 val s = "uw_" ^ s
2489 val e_name = (L'.EPrim (Prim.String s), loc) 2507 val e_name = (L'.EPrim (Prim.String s), loc)
2613 2631
2614 val e = (L'.ERecord [], loc) 2632 val e = (L'.ERecord [], loc)
2615 in 2633 in
2616 foldl (fn ((d, _), e) => 2634 foldl (fn ((d, _), e) =>
2617 case d of 2635 case d of
2618 L.DTable (_, _, xts, tab, _) => doTable (tab, #1 xts, e) 2636 L.DTable (_, _, xts, tab, _, _) => doTable (tab, #1 xts, e)
2619 | _ => e) e file 2637 | _ => e) e file
2620 end 2638 end
2621 2639
2622 fun initializer () = 2640 fun initializer () =
2623 let 2641 let
2658 2676
2659 val e = (L'.ERecord [], loc) 2677 val e = (L'.ERecord [], loc)
2660 in 2678 in
2661 foldl (fn ((d, _), e) => 2679 foldl (fn ((d, _), e) =>
2662 case d of 2680 case d of
2663 L.DTable (_, _, xts, tab, _) => doTable (tab, #1 xts, e) 2681 L.DTable (_, _, xts, tab, _, _) => doTable (tab, #1 xts, e)
2664 | _ => e) e file 2682 | _ => e) e file
2665 end 2683 end
2666 2684
2667 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) => 2685 val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
2668 case #1 d of 2686 case #1 d of