src/Pure/Isar/proof_context.ML
changeset 63515 6c46a1e786da
parent 63514 d4d3df24f536
child 63518 ae8fd6fe63a1
equal deleted inserted replaced
63514:d4d3df24f536 63515:6c46a1e786da
   221 val mode_abbrev    = make_mode (false, false, true);
   221 val mode_abbrev    = make_mode (false, false, true);
   222 
   222 
   223 
   223 
   224 (** Isar proof context information **)
   224 (** Isar proof context information **)
   225 
   225 
   226 type cases = ((Rule_Cases.T * {legacy: bool}) * int) Name_Space.table;
   226 type cases = (Rule_Cases.T * {legacy: bool}) Name_Space.table;
   227 val empty_cases: cases = Name_Space.empty_table Markup.caseN;
   227 val empty_cases: cases = Name_Space.empty_table Markup.caseN;
   228 
   228 
   229 datatype data =
   229 datatype data =
   230   Data of
   230   Data of
   231    {mode: mode,                  (*inner syntax mode*)
   231    {mode: mode,                  (*inner syntax mode*)
  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")