src/HOL/Tools/Ctr_Sugar/ctr_sugar.ML
changeset 69593 3dda49e08b9d
parent 67405 e9ab4ad7bd15
child 69597 ff784d5a5bfb
equal deleted inserted replaced
69592:a80d8ec6c998 69593:3dda49e08b9d
   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;