1273 |
1273 |
1274 (** cases **) |
1274 (** cases **) |
1275 |
1275 |
1276 fun dest_cases prev_ctxt ctxt = |
1276 fun dest_cases prev_ctxt ctxt = |
1277 let |
1277 let |
|
1278 val serial_of = #serial oo (Name_Space.the_entry o Name_Space.space_of_table); |
1278 val ignored = |
1279 val ignored = |
1279 (case prev_ctxt of |
1280 (case prev_ctxt of |
1280 NONE => Inttab.empty |
1281 NONE => Inttab.empty |
1281 | SOME ctxt0 => |
1282 | SOME ctxt0 => |
1282 Name_Space.fold_table (Inttab.insert_set o #2 o #2) (cases_of ctxt0) Inttab.empty); |
1283 let val cases0 = cases_of ctxt0 in |
|
1284 Name_Space.fold_table (fn (a, _) => Inttab.insert_set (serial_of cases0 a)) |
|
1285 cases0 Inttab.empty |
|
1286 end); |
|
1287 val cases = cases_of ctxt; |
1283 in |
1288 in |
1284 Name_Space.fold_table (fn (a, (c, i)) => |
1289 Name_Space.fold_table (fn (a, c) => |
1285 not (Inttab.defined ignored i) ? cons (i, (a, c))) (cases_of ctxt) [] |
1290 let val i = serial_of cases a |
|
1291 in not (Inttab.defined ignored i) ? cons (i, (a, c)) end) cases [] |
1286 |> sort (int_ord o apply2 #1) |> map #2 |
1292 |> sort (int_ord o apply2 #1) |> map #2 |
1287 end; |
1293 end; |
1288 |
1294 |
1289 local |
1295 local |
1290 |
1296 |
1291 fun drop_schematic (b as (xi, SOME t)) = if Term.exists_subterm is_Var t then (xi, NONE) else b |
1297 fun drop_schematic (b as (xi, SOME t)) = if Term.exists_subterm is_Var t then (xi, NONE) else b |
1292 | drop_schematic b = b; |
1298 | drop_schematic b = b; |
1293 |
1299 |
1294 fun update_case _ _ ("", _) res = res |
1300 fun update_case _ _ ("", _) cases = cases |
1295 | update_case _ _ (name, NONE) (cases, index) = |
1301 | update_case _ _ (name, NONE) cases = Name_Space.del_table name cases |
1296 (Name_Space.del_table name cases, index) |
1302 | update_case context legacy (name, SOME c) cases = |
1297 | update_case context legacy (name, SOME c) (cases, index) = |
|
1298 let |
1303 let |
1299 val binding = Binding.name name |> legacy ? Binding.concealed; |
1304 val binding = Binding.name name |> legacy ? Binding.concealed; |
1300 val (_, cases') = cases |
1305 val (_, cases') = Name_Space.define context false (binding, (c, {legacy = legacy})) cases; |
1301 |> Name_Space.define context false (binding, ((c, {legacy = legacy}), index)); |
1306 in cases' end; |
1302 val index' = index + 1; |
|
1303 in (cases', index') end; |
|
1304 |
1307 |
1305 fun update_cases' legacy args ctxt = |
1308 fun update_cases' legacy args ctxt = |
1306 let |
1309 let val context = Context.Proof ctxt |> Name_Space.map_naming (K Name_Space.global_naming); |
1307 val context = Context.Proof ctxt |> Name_Space.map_naming (K Name_Space.global_naming); |
1310 in map_cases (fold (update_case context legacy) args) ctxt end; |
1308 val cases = cases_of ctxt; |
|
1309 val index = Name_Space.fold_table (fn _ => Integer.add 1) cases 0; |
|
1310 val (cases', _) = fold (update_case context legacy) args (cases, index); |
|
1311 in map_cases (K cases') ctxt end; |
|
1312 |
1311 |
1313 fun fix (b, T) ctxt = |
1312 fun fix (b, T) ctxt = |
1314 let val ([x], ctxt') = add_fixes [(b, SOME T, NoSyn)] ctxt |
1313 let val ([x], ctxt') = add_fixes [(b, SOME T, NoSyn)] ctxt |
1315 in (Free (x, T), ctxt') end; |
1314 in (Free (x, T), ctxt') end; |
1316 |
1315 |
1333 |
1332 |
1334 val apply_case = apfst fst oo case_result; |
1333 val apply_case = apfst fst oo case_result; |
1335 |
1334 |
1336 fun check_case ctxt internal (name, pos) param_specs = |
1335 fun check_case ctxt internal (name, pos) param_specs = |
1337 let |
1336 let |
1338 val (_, ((Rule_Cases.Case {fixes, assumes, binds, cases}, {legacy}), _)) = |
1337 val (_, (Rule_Cases.Case {fixes, assumes, binds, cases}, {legacy})) = |
1339 Name_Space.check (Context.Proof ctxt) (cases_of ctxt) (name, pos); |
1338 Name_Space.check (Context.Proof ctxt) (cases_of ctxt) (name, pos); |
1340 val _ = |
1339 val _ = |
1341 if legacy then |
1340 if legacy then |
1342 legacy_feature ("Bad case " ^ quote name ^ Position.here pos ^ |
1341 legacy_feature ("Bad case " ^ quote name ^ Position.here pos ^ |
1343 " -- use proof method \"goal_cases\" instead") |
1342 " -- use proof method \"goal_cases\" instead") |