278 fun join_halves n half_xss other_half_xss = |
278 fun join_halves n half_xss other_half_xss = |
279 (splice (flat half_xss) (flat other_half_xss), |
279 (splice (flat half_xss) (flat other_half_xss), |
280 map2 (map2 append) (Library.chop_groups n half_xss) |
280 map2 (map2 append) (Library.chop_groups n half_xss) |
281 (transpose (Library.chop_groups n other_half_xss))); |
281 (transpose (Library.chop_groups n other_half_xss))); |
282 |
282 |
283 fun mk_undefined T = Const (@{const_name undefined}, T); |
283 fun mk_undefined T = Const (\<^const_name>\<open>undefined\<close>, T); |
284 |
284 |
285 fun mk_ctr Ts t = |
285 fun mk_ctr Ts t = |
286 let val Type (_, Ts0) = body_type (fastype_of t) in |
286 let val Type (_, Ts0) = body_type (fastype_of t) in |
287 subst_nonatomic_types (Ts0 ~~ Ts) t |
287 subst_nonatomic_types (Ts0 ~~ Ts) t |
288 end; |
288 end; |
299 |
299 |
300 fun name_of_disc t = |
300 fun name_of_disc t = |
301 (case head_of t of |
301 (case head_of t of |
302 Abs (_, _, @{const Not} $ (t' $ Bound 0)) => |
302 Abs (_, _, @{const Not} $ (t' $ Bound 0)) => |
303 Long_Name.map_base_name (prefix not_prefix) (name_of_disc t') |
303 Long_Name.map_base_name (prefix not_prefix) (name_of_disc t') |
304 | Abs (_, _, Const (@{const_name HOL.eq}, _) $ Bound 0 $ t') => |
304 | Abs (_, _, Const (\<^const_name>\<open>HOL.eq\<close>, _) $ Bound 0 $ t') => |
305 Long_Name.map_base_name (prefix is_prefix) (name_of_disc t') |
305 Long_Name.map_base_name (prefix is_prefix) (name_of_disc t') |
306 | Abs (_, _, @{const Not} $ (Const (@{const_name HOL.eq}, _) $ Bound 0 $ t')) => |
306 | Abs (_, _, @{const Not} $ (Const (\<^const_name>\<open>HOL.eq\<close>, _) $ Bound 0 $ t')) => |
307 Long_Name.map_base_name (prefix (not_prefix ^ is_prefix)) (name_of_disc t') |
307 Long_Name.map_base_name (prefix (not_prefix ^ is_prefix)) (name_of_disc t') |
308 | t' => name_of_const "discriminator" (perhaps (try domain_type)) t'); |
308 | t' => name_of_const "discriminator" (perhaps (try domain_type)) t'); |
309 |
309 |
310 val base_name_of_ctr = Long_Name.base_name o name_of_ctr; |
310 val base_name_of_ctr = Long_Name.base_name o name_of_ctr; |
311 |
311 |
378 |
378 |
379 fun disc_of_ctr_spec ((disc, _), _) = disc; |
379 fun disc_of_ctr_spec ((disc, _), _) = disc; |
380 fun ctr_of_ctr_spec ((_, ctr), _) = ctr; |
380 fun ctr_of_ctr_spec ((_, ctr), _) = ctr; |
381 fun args_of_ctr_spec (_, args) = args; |
381 fun args_of_ctr_spec (_, args) = args; |
382 |
382 |
383 val code_plugin = Plugin_Name.declare_setup @{binding code}; |
383 val code_plugin = Plugin_Name.declare_setup \<^binding>\<open>code\<close>; |
384 |
384 |
385 fun prepare_free_constructors kind prep_plugins prep_term |
385 fun prepare_free_constructors kind prep_plugins prep_term |
386 ((((raw_plugins, discs_sels), raw_case_binding), ctr_specs), sel_default_eqs) no_defs_lthy = |
386 ((((raw_plugins, discs_sels), raw_case_binding), ctr_specs), sel_default_eqs) no_defs_lthy = |
387 let |
387 let |
388 val plugins = prep_plugins no_defs_lthy raw_plugins; |
388 val plugins = prep_plugins no_defs_lthy raw_plugins; |
429 not (Binding.is_empty (nth raw_disc_bindings (k - 1))) orelse nth ms (k - 1) = 0; |
429 not (Binding.is_empty (nth raw_disc_bindings (k - 1))) orelse nth ms (k - 1) = 0; |
430 fun can_rely_on_disc k = |
430 fun can_rely_on_disc k = |
431 can_definitely_rely_on_disc k orelse (k = 1 andalso not (can_definitely_rely_on_disc 2)); |
431 can_definitely_rely_on_disc k orelse (k = 1 andalso not (can_definitely_rely_on_disc 2)); |
432 fun should_omit_disc_binding k = n = 1 orelse (n = 2 andalso can_rely_on_disc (3 - k)); |
432 fun should_omit_disc_binding k = n = 1 orelse (n = 2 andalso can_rely_on_disc (3 - k)); |
433 |
433 |
434 val equal_binding = @{binding "="}; |
434 val equal_binding = \<^binding>\<open>=\<close>; |
435 |
435 |
436 fun is_disc_binding_valid b = |
436 fun is_disc_binding_valid b = |
437 not (Binding.is_empty b orelse Binding.eq_name (b, equal_binding)); |
437 not (Binding.is_empty b orelse Binding.eq_name (b, equal_binding)); |
438 |
438 |
439 val standard_disc_binding = Binding.name o prefix is_prefix o base_name_of_ctr; |
439 val standard_disc_binding = Binding.name o prefix is_prefix o base_name_of_ctr; |
502 |
502 |
503 fun mk_case_disj xctr xf xs = |
503 fun mk_case_disj xctr xf xs = |
504 list_exists_free xs (HOLogic.mk_conj (HOLogic.mk_eq (u, xctr), HOLogic.mk_eq (w, xf))); |
504 list_exists_free xs (HOLogic.mk_conj (HOLogic.mk_eq (u, xctr), HOLogic.mk_eq (w, xf))); |
505 |
505 |
506 val case_rhs = fold_rev (fold_rev Term.lambda) [fs, [u]] |
506 val case_rhs = fold_rev (fold_rev Term.lambda) [fs, [u]] |
507 (Const (@{const_name The}, (B --> HOLogic.boolT) --> B) $ |
507 (Const (\<^const_name>\<open>The\<close>, (B --> HOLogic.boolT) --> B) $ |
508 Term.lambda w (Library.foldr1 HOLogic.mk_disj (@{map 3} mk_case_disj xctrs xfs xss))); |
508 Term.lambda w (Library.foldr1 HOLogic.mk_disj (@{map 3} mk_case_disj xctrs xfs xss))); |
509 |
509 |
510 val ((raw_case, (_, raw_case_def)), (lthy, lthy_old)) = no_defs_lthy |
510 val ((raw_case, (_, raw_case_def)), (lthy, lthy_old)) = no_defs_lthy |
511 |> Local_Theory.open_target |> snd |
511 |> Local_Theory.open_target |> snd |
512 |> Local_Theory.define ((case_binding, NoSyn), |
512 |> Local_Theory.define ((case_binding, NoSyn), |
830 |
830 |
831 val sel_thmss = @{map 3} (map oo make_sel_thm) xss' case_thms sel_defss; |
831 val sel_thmss = @{map 3} (map oo make_sel_thm) xss' case_thms sel_defss; |
832 |
832 |
833 fun has_undefined_rhs thm = |
833 fun has_undefined_rhs thm = |
834 (case snd (HOLogic.dest_eq (HOLogic.dest_Trueprop (Thm.prop_of thm))) of |
834 (case snd (HOLogic.dest_eq (HOLogic.dest_Trueprop (Thm.prop_of thm))) of |
835 Const (@{const_name undefined}, _) => true |
835 Const (\<^const_name>\<open>undefined\<close>, _) => true |
836 | _ => false); |
836 | _ => false); |
837 |
837 |
838 val all_sel_thms = |
838 val all_sel_thms = |
839 (if all_sels_distinct andalso null sel_default_eqs then |
839 (if all_sels_distinct andalso null sel_default_eqs then |
840 flat sel_thmss |
840 flat sel_thmss |
1156 |
1156 |
1157 fun free_constructors_cmd kind = (fn (goalss, after_qed, lthy) => |
1157 fun free_constructors_cmd kind = (fn (goalss, after_qed, lthy) => |
1158 Proof.theorem NONE (snd oo after_qed) (map (map (rpair [])) goalss) lthy) oo |
1158 Proof.theorem NONE (snd oo after_qed) (map (map (rpair [])) goalss) lthy) oo |
1159 prepare_free_constructors kind Plugin_Name.make_filter Syntax.read_term; |
1159 prepare_free_constructors kind Plugin_Name.make_filter Syntax.read_term; |
1160 |
1160 |
1161 val parse_bound_term = Parse.binding --| @{keyword ":"} -- Parse.term; |
1161 val parse_bound_term = Parse.binding --| \<^keyword>\<open>:\<close> -- Parse.term; |
1162 |
1162 |
1163 type ctr_options = Plugin_Name.filter * bool; |
1163 type ctr_options = Plugin_Name.filter * bool; |
1164 type ctr_options_cmd = (Proof.context -> Plugin_Name.filter) * bool; |
1164 type ctr_options_cmd = (Proof.context -> Plugin_Name.filter) * bool; |
1165 |
1165 |
1166 val default_ctr_options : ctr_options = (Plugin_Name.default_filter, false); |
1166 val default_ctr_options : ctr_options = (Plugin_Name.default_filter, false); |
1167 val default_ctr_options_cmd : ctr_options_cmd = (K Plugin_Name.default_filter, false); |
1167 val default_ctr_options_cmd : ctr_options_cmd = (K Plugin_Name.default_filter, false); |
1168 |
1168 |
1169 val parse_ctr_options = |
1169 val parse_ctr_options = |
1170 Scan.optional (@{keyword "("} |-- Parse.list1 |
1170 Scan.optional (\<^keyword>\<open>(\<close> |-- Parse.list1 |
1171 (Plugin_Name.parse_filter >> (apfst o K) |
1171 (Plugin_Name.parse_filter >> (apfst o K) |
1172 || Parse.reserved "discs_sels" >> (apsnd o K o K true)) --| |
1172 || Parse.reserved "discs_sels" >> (apsnd o K o K true)) --| |
1173 @{keyword ")"} |
1173 \<^keyword>\<open>)\<close> |
1174 >> (fn fs => fold I fs default_ctr_options_cmd)) |
1174 >> (fn fs => fold I fs default_ctr_options_cmd)) |
1175 default_ctr_options_cmd; |
1175 default_ctr_options_cmd; |
1176 |
1176 |
1177 fun parse_ctr_spec parse_ctr parse_arg = |
1177 fun parse_ctr_spec parse_ctr parse_arg = |
1178 parse_opt_binding_colon -- parse_ctr -- Scan.repeat parse_arg; |
1178 parse_opt_binding_colon -- parse_ctr -- Scan.repeat parse_arg; |
1179 |
1179 |
1180 val parse_ctr_specs = Parse.enum1 "|" (parse_ctr_spec Parse.term Parse.binding); |
1180 val parse_ctr_specs = Parse.enum1 "|" (parse_ctr_spec Parse.term Parse.binding); |
1181 val parse_sel_default_eqs = Scan.optional (@{keyword "where"} |-- Parse.enum1 "|" Parse.prop) []; |
1181 val parse_sel_default_eqs = Scan.optional (\<^keyword>\<open>where\<close> |-- Parse.enum1 "|" Parse.prop) []; |
1182 |
1182 |
1183 val _ = |
1183 val _ = |
1184 Outer_Syntax.local_theory_to_proof @{command_keyword free_constructors} |
1184 Outer_Syntax.local_theory_to_proof \<^command_keyword>\<open>free_constructors\<close> |
1185 "register an existing freely generated type's constructors" |
1185 "register an existing freely generated type's constructors" |
1186 (parse_ctr_options -- Parse.binding --| @{keyword "for"} -- parse_ctr_specs |
1186 (parse_ctr_options -- Parse.binding --| \<^keyword>\<open>for\<close> -- parse_ctr_specs |
1187 -- parse_sel_default_eqs |
1187 -- parse_sel_default_eqs |
1188 >> free_constructors_cmd Unknown); |
1188 >> free_constructors_cmd Unknown); |
1189 |
1189 |
1190 end; |
1190 end; |