src/HOL/Tools/record.ML
changeset 46055 20e5060ab75c
parent 46054 3458b0e955ac
child 46056 4dba48d010d5
equal deleted inserted replaced
46054:3458b0e955ac 46055:20e5060ab75c
  1643             cut_rules_tac [split_meta RS Drule.equal_elim_rule2] 1 THEN
  1643             cut_rules_tac [split_meta RS Drule.equal_elim_rule2] 1 THEN
  1644             resolve_tac prems 2 THEN
  1644             resolve_tac prems 2 THEN
  1645             asm_simp_tac HOL_ss 1)
  1645             asm_simp_tac HOL_ss 1)
  1646       end);
  1646       end);
  1647 
  1647 
  1648     val ([induct', inject', surjective', split_meta'], thm_thy) =
  1648     val ([(_, [induct']), (_, [inject']), (_, [surjective']), (_, [split_meta'])], thm_thy) =
  1649       defs_thy
  1649       defs_thy
  1650       |> Global_Theory.add_thms (map (Thm.no_attributes o apfst Binding.name)
  1650       |> Global_Theory.note_thmss ""
  1651            [("ext_induct", induct),
  1651           [((Binding.name "ext_induct", []), [([induct], [])]),
  1652             ("ext_inject", inject),
  1652            ((Binding.name "ext_inject", []), [([inject], [])]),
  1653             ("ext_surjective", surject),
  1653            ((Binding.name "ext_surjective", []), [([surject], [])]),
  1654             ("ext_split", split_meta)]);
  1654            ((Binding.name "ext_split", []), [([split_meta], [])])];
  1655 
       
  1656   in
  1655   in
  1657     (((ext_name, ext_type), (ext_tyco, alphas_zeta),
  1656     (((ext_name, ext_type), (ext_tyco, alphas_zeta),
  1658       extT, induct', inject', surjective', split_meta', ext_def), thm_thy)
  1657       extT, induct', inject', surjective', split_meta', ext_def), thm_thy)
  1659   end;
  1658   end;
  1660 
  1659 
  2179 
  2178 
  2180     val equality = timeit_msg ctxt "record equality proof:" (fn () =>
  2179     val equality = timeit_msg ctxt "record equality proof:" (fn () =>
  2181       Skip_Proof.prove_global defs_thy [] [] equality_prop
  2180       Skip_Proof.prove_global defs_thy [] [] equality_prop
  2182         (fn _ => asm_full_simp_tac (record_ss addsimps (split_meta :: sel_convs)) 1));
  2181         (fn _ => asm_full_simp_tac (record_ss addsimps (split_meta :: sel_convs)) 1));
  2183 
  2182 
  2184     val ((([sel_convs', upd_convs', sel_defs', upd_defs',
  2183     val ([(_, sel_convs'), (_, upd_convs'), (_, sel_defs'), (_, upd_defs'),
  2185             fold_congs', unfold_congs',
  2184           (_, fold_congs'), (_, unfold_congs'),
  2186           splits' as [split_meta', split_object', split_ex'], derived_defs'],
  2185           (_, splits' as [split_meta', split_object', split_ex']), (_, derived_defs'),
  2187           [surjective', equality']),
  2186           (_, [surjective']), (_, [equality']), (_, [induct_scheme']), (_, [induct']),
  2188           [induct_scheme', induct', cases_scheme', cases']), thms_thy) =
  2187           (_, [cases_scheme']), (_, [cases'])], thms_thy) = defs_thy
  2189       defs_thy
  2188       |> Global_Theory.note_thmss ""
  2190       |> (Global_Theory.add_thmss o map (Thm.no_attributes o apfst Binding.name))
  2189        [((Binding.name "select_convs", []), [(sel_convs, [])]),
  2191          [("select_convs", sel_convs),
  2190         ((Binding.name "update_convs", []), [(upd_convs, [])]),
  2192           ("update_convs", upd_convs),
  2191         ((Binding.name "select_defs", []), [(sel_defs, [])]),
  2193           ("select_defs", sel_defs),
  2192         ((Binding.name "update_defs", []), [(upd_defs, [])]),
  2194           ("update_defs", upd_defs),
  2193         ((Binding.name "fold_congs", []), [(fold_congs, [])]),
  2195           ("fold_congs", fold_congs),
  2194         ((Binding.name "unfold_congs", []), [(unfold_congs, [])]),
  2196           ("unfold_congs", unfold_congs),
  2195         ((Binding.name "splits", []), [([split_meta, split_object, split_ex], [])]),
  2197           ("splits", [split_meta, split_object, split_ex]),
  2196         ((Binding.name "defs", []), [(derived_defs, [])]),
  2198           ("defs", derived_defs)]
  2197         ((Binding.name "surjective", []), [([surjective], [])]),
  2199       ||>> (Global_Theory.add_thms o map (Thm.no_attributes o apfst Binding.name))
  2198         ((Binding.name "equality", []), [([equality], [])]),
  2200           [("surjective", surjective),
  2199         ((Binding.name "induct_scheme", induct_type_global (suffix schemeN name)),
  2201            ("equality", equality)]
  2200           [([induct_scheme], [])]),
  2202       ||>> (Global_Theory.add_thms o (map o apfst o apfst) Binding.name)
  2201         ((Binding.name "induct", induct_type_global name), [([induct], [])]),
  2203         [(("induct_scheme", induct_scheme), induct_type_global (suffix schemeN name)),
  2202         ((Binding.name "cases_scheme", cases_type_global (suffix schemeN name)),
  2204          (("induct", induct), induct_type_global name),
  2203           [([cases_scheme], [])]),
  2205          (("cases_scheme", cases_scheme), cases_type_global (suffix schemeN name)),
  2204         ((Binding.name "cases", cases_type_global name), [([cases], [])])];
  2206          (("cases", cases), cases_type_global name)];
       
  2207 
  2205 
  2208     val sel_upd_simps = sel_convs' @ upd_convs';
  2206     val sel_upd_simps = sel_convs' @ upd_convs';
  2209     val sel_upd_defs = sel_defs' @ upd_defs';
  2207     val sel_upd_defs = sel_defs' @ upd_defs';
  2210     val depth = parent_len + 1;
  2208     val depth = parent_len + 1;
  2211 
  2209 
  2212     val ([simps', iffs'], thms_thy') =
  2210     val ([(_, simps'), (_, iffs')], thms_thy') = thms_thy
  2213       thms_thy
  2211       |> Global_Theory.note_thmss ""
  2214       |> Global_Theory.add_thmss
  2212           [((Binding.name "simps", [Simplifier.simp_add]), [(sel_upd_simps, [])]),
  2215           [((Binding.name "simps", sel_upd_simps), [Simplifier.simp_add]),
  2213            ((Binding.name "iffs", [iff_add]), [([ext_inject], [])])];
  2216            ((Binding.name "iffs", [ext_inject]), [iff_add])];
       
  2217 
  2214 
  2218     val info =
  2215     val info =
  2219       make_info alphas parent fields extension
  2216       make_info alphas parent fields extension
  2220         ext_induct ext_inject ext_surjective ext_split ext_def
  2217         ext_induct ext_inject ext_surjective ext_split ext_def
  2221         sel_convs' upd_convs' sel_defs' upd_defs' fold_congs' unfold_congs' splits' derived_defs'
  2218         sel_convs' upd_convs' sel_defs' upd_defs' fold_congs' unfold_congs' splits' derived_defs'